home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 18 REXX / 18-REXX.zip / rexxalgo.zip / RXALG131.FNC (.txt) < prev   
OS/2 INI File  |  1997-08-11  |  37KB  |  800 lines
  1. Rexx Algorithms
  2. Binary Search
  3. /*==================(Binary search)===================*/
  4. /* :-D                                              1 */
  5. /* Name.......: BiSearch                              */
  6. /*                                                    */
  7. /* Function...: Search a stem variable for a value    */
  8. /* Call parm..: Search value                          */
  9. /* Returns....: 0 if nothing found                    */
  10. /*              index of the found value              */
  11. /* Sample call: found_index = BiSearch(value)         */
  12. /*              If found_index = 0 Then               */
  13. /*                Say 'Value' value 'not found!'      */
  14. /*              Else                                  */
  15. /*                Say stem.found_index                */
  16. /*                                                    */
  17. /* Notes......: The elements to search for must be    */
  18. /*              saved in the stem named so as the     */
  19. /*              stem in this Procedure (in this case  */
  20. /*              "STEM.")                              */
  21. /*              stem.0 must contain the number of     */
  22. /*              elements in stem.                     */
  23. /*              The stem-variable must be in the      */
  24. /*              sorted order                          */
  25. /*                                                    */
  26. /* Changes....: No                                    */
  27. /*                                                    */
  28. /* (C) Copyright Janosch R. Kowalczyk, 1996.          */
  29. /* All rights reserved.                               */
  30. /*====================================================*/
  31. BiSearch: Procedure Expose stem.
  32. Parse Arg value             /* Search value            */
  33. found  = 0                  /* Index of the found Item */
  34. bottom = 1                  /* Index of the first Item */
  35. top    = stem.0             /* Index of the last Item  */
  36. Do While found = 0 & top >= bottom
  37.   mean = (bottom + top) % 2
  38.   If value = stem.mean Then
  39.     found = mean
  40.   Else If value < stem.mean Then
  41.     top = mean - 1
  42.   Else
  43.     bottom = mean + 1
  44. End /* Do While */
  45. Return found
  46. Recursive Formatting
  47. /*==============( Recursive formatting )==============*/
  48. /*                                                 13 */
  49. /* Name.......: Combine                               */
  50. /*                                                    */
  51. /* Function...: Format recursive a string             */
  52. /*                                                    */
  53. /* Call parm..: _combStr   - string to format,        */
  54. /*              _combLen   - string's length,         */
  55. /*              _combTooth - format string (opt.),    */
  56. /*              _combRep   - format interval (opt.)   */
  57. /*                                                    */
  58. /* Returns....: formated string                       */
  59. /*                                                    */
  60. /* Syntax.....:                                       */
  61. /*    formStr = Combine( Str, Len, Tooth, Rep )       */
  62. /*                                                    */
  63. /* Notes......: Default value for _combTooth is a     */
  64. /*              blank                                 */
  65. /*              Default value for _combRep is 1       */
  66. /*                                                    */
  67. /* Method of working:                                 */
  68. /*              _combTooth will be inserted into the  */
  69. /*              _combStr at the position computed as  */
  70. /*              follows:                              */
  71. /*              _combLen = _combLen - _combRep        */
  72. /*                                                    */
  73. /* Sample.....: Input string  = '10000000000'         */
  74. /*              Format string = '.'                   */
  75. /*              Interval      = 3                     */
  76. /*                                                    */
  77. /*              Output string = '10.000.000.000'      */
  78. /*                                                    */
  79. /* Changes....: No                                    */
  80. /*                                                    */
  81. /* (C) Copyright Janosch R. Kowalczyk, 1996.          */
  82. /* All rights reserved.                               */
  83. /*====================================================*/
  84. Combine: Procedure
  85. Parse Arg _combStr, _combLen, _combTooth, _combRep
  86. /*----(End processing and return formated string)-----*/
  87. If _combLen < 1 | DataType(_combLen, 'N') = 0 Then
  88.   Return _combStr
  89. /*---(Check call parameter and set default values)----*/
  90. _combLen = Trunc( _combLen )
  91. If _combTooth = '' Then
  92.   _combTooth = ' '
  93. If _combRep < 1 | DataType(_combRep, 'N') = 0 Then
  94.   _combRep = 1
  95. Else If _combRep >= _combLen Then
  96.   Return _combStr
  97. _combRep = Trunc( _combRep )
  98. /*---------(Set new value for Insert position)---------*/
  99. _combLen = _combLen - _combRep
  100. /*---------(Call recursive for the naxt step)----------*/
  101. Return Combine( Insert( _combTooth, _combStr, _combLen ),,
  102.                 _combLen,,
  103.                 _combTooth,,
  104.                 _combRep )
  105. Bubble Sort
  106. /*===================(Bubble sort)====================*/
  107. /* :-I                                              2 */
  108. /* Name.......: BubSort                               */
  109. /*                                                    */
  110. /* Function...: Bubble Sort for a stem variable       */
  111. /* Call parm..: No                                    */
  112. /* Returns....: nothing (NULL string)                 */
  113. /*                                                    */
  114. /* Sample call: Call BubSort                          */
  115. /*                                                    */
  116. /* Notes......: The elements to sort for must be      */
  117. /*              saved in the stem named so as the     */
  118. /*              stem in this Procedure (in this case  */
  119. /*              "STEM.")                              */
  120. /*              stem.0 must contain the number of     */
  121. /*              elements in stem.                     */
  122. /*                                                    */
  123. /* Changes....: No                                    */
  124. /*                                                    */
  125. /* (C) Copyright Janosch R. Kowalczyk, 1996.          */
  126. /* All rights reserved.                               */
  127. /*====================================================*/
  128. BubSort: Procedure Expose stem.
  129. Do i = stem.0 To 1 By -1 Until flip_flop = 1
  130.   flip_flop = 1
  131.   Do j = 2 To i
  132.     m = j - 1
  133.     If stem.m > stem.j Then Do
  134.       xchg   = stem.m
  135.       stem.m = stem.j
  136.       stem.j = xchg
  137.       flip_flop = 0
  138.     End /* If stem.m ... */
  139.   End /* Do j = 2 ...    */
  140. End /* Do i = stem.0 ... */
  141. Return ''
  142. Date 2000
  143. /*=======(Translate year to year with century)========*/
  144. /*                                                 11 */
  145. /* Name.......: Date2000                              */
  146. /*                                                    */
  147. /* Function...: Translates year to year with century  */
  148. /* Call option:   Returns dd Mmm yyyy                 */
  149. /*              B Returns dddddd days since 01.01.0001*/
  150. /*              D Returns ddd - days                  */
  151. /*              E Returns dd/mm/yyyy                  */
  152. /*              J Returns yyyy.ddd - julians date     */
  153. /*              L Returns dd Month yyyy               */
  154. /*              M Returns Month                       */
  155. /*              N Returns dd Mmm yyyy                 */
  156. /*              O Returns yyyy/mm/dd                  */
  157. /*              S Returns yyyymmdd                    */
  158. /*              U Returns mm/dd/yyyy                  */
  159. /*              W Returns Weekday                     */
  160. /*                                                    */
  161. /* Syntax.....: Date = Date2000(Option)               */
  162. /*                                                    */
  163. /* Changes....: No                                    */
  164. /*                                                    */
  165. /* (C) Copyright Janosch R. Kowalczyk, 1996.          */
  166. /* All rights reserved.                               */
  167. /*====================================================*/
  168. Date2000: Procedure
  169. Parse Value Arg(1) With Option +1 .
  170. If Option = '' Then Return Date()
  171. If Verify('EJOU', Option, 'M') > 0 Then Do
  172.   Parse Value Date() With . . yyyy
  173.   If Option = 'J' Then Return yyyy || '.' || Date('D')
  174.   Else If Option = 'O' Then Do
  175.     Parse Value Date(Option) With . +2 Rest
  176.     Return yyyy || Rest
  177.   End
  178.   Else Do
  179.     Parse Value Date(Option) With Rest +6 .
  180.     Return Rest || yyyy
  181.   End
  182. Else Return Date(Option)
  183. Exclude multiple items 
  184. /*=============( Exclude multiple items )=============*/
  185. /*                                                 11 */
  186. /* Name.......: NoMult                                */
  187. /*                                                    */
  188. /* Function...: Excludes multiple lines from a sorted */
  189. /*              file                                  */
  190. /* Call parm..: nothing                               */
  191. /* Returns....: nothing (0)                           */
  192. /*                                                    */
  193. /* Syntax.....: Call NoMult / y = NoMult()            */
  194. /*                                                    */
  195. /* Notes......: The elements to exclude must be       */
  196. /*              saved in the stem named so as the     */
  197. /*              stem in this Procedure (in this case  */
  198. /*              "STEM.")                              */
  199. /*              stem.0 must contain the number of     */
  200. /*              elements in stem.                     */
  201. /*              The stem variable must be previously  */
  202. /*              sorted                                */
  203. /*                                                    */
  204. /* Changes....: No                                    */
  205. /*                                                    */
  206. /* (C) Copyright Janosch R. Kowalczyk, 1996.          */
  207. /* All rights reserved.                               */
  208. /*====================================================*/
  209. NoMult: Procedure Expose stem.
  210. Do i = 1 To stem.0
  211.   Queue stem.i
  212.   Do j = i + 1 while stem.i = stem.j
  213.   End
  214.   i = j - 1
  215. Return 0
  216. Insertion Sort
  217. /*=================(Insertion sort)===================*/
  218. /* :-!                                              3 */
  219. /* Name.......: InsSort                               */
  220. /*                                                    */
  221. /* Function...: Insertion Sort for a stem variable    */
  222. /* Call parm..: No                                    */
  223. /* Returns....: nothing (NULL string)                 */
  224. /*                                                    */
  225. /* Sample call: Call InsSort                          */
  226. /*                                                    */
  227. /* Notes......: The elements to sort for must be      */
  228. /*              saved in the stem named so as the     */
  229. /*              stem in this Procedure (in this case  */
  230. /*              "STEM.")                              */
  231. /*              stem.0 must contain the number of     */
  232. /*              elements in stem.                     */
  233. /*                                                    */
  234. /* Changes....: No                                    */
  235. /*                                                    */
  236. /* (C) Copyright Janosch R. Kowalczyk, 1996.          */
  237. /* All rights reserved.                               */
  238. /*====================================================*/
  239. InsSort: Procedure Expose stem.
  240. Do x = 2 To stem.0
  241.   xchg = stem.x
  242.   Do y = x - 1 By -1 To 1 While stem.y > xchg
  243.     xchg   = stem.x
  244.     stem.x = stem.y
  245.     stem.y = xchg
  246.     x = y
  247.   End /* Do y = x... */
  248.   stem.x = xchg
  249. End /* Do x = 2 ...  */
  250. Return ''
  251. Julian to gregorian date
  252. /*========(Translate julian to gregorian date)========*/
  253. /*                                                 10 */
  254. /* Name.......: J2G                                   */
  255. /*                                                    */
  256. /* Function...: translates julian to gregorian date   */
  257. /*              julian date                           */
  258. /* Call parm..: julian date in format yyyy.ddd        */
  259. /* Returns....: julian date (yyyy.mm.dd)              */
  260. /*                                                    */
  261. /* Syntax.....: gregDate = J2G(yyyy.gdd)              */
  262. /*                                                    */
  263. /* Changes....: No                                    */
  264. /*                                                    */
  265. /* (C) Copyright Janosch R. Kowalczyk, 1996.          */
  266. /* All rights reserved.                               */
  267. /*====================================================*/
  268. J2G: Procedure
  269. Arg julDate
  270. Parse Var julDate year'.'jday
  271. mon.1  = 0
  272. mon.2  = 31
  273. mon.3  = 59
  274. mon.4  = 90
  275. mon.5  = 120
  276. mon.6  = 151
  277. mon.7  = 181
  278. mon.8  = 212
  279. mon.9  = 243
  280. mon.10 = 273
  281. mon.11 = 304
  282. mon.12 = 334
  283. If year // 400 = 0 | (year // 100 > 0 & year // 4 = 0) Then
  284.   leap = 1
  285.   leap = 0
  286. Do i = 1 To 12 
  287.   If i > 2 Then mon.i = mon.i + leap
  288.   If jday > mon.i Then mon = i
  289. day = jday - mon.mon
  290. gregDate = year'.'Right(mon,2,'0')'.'Right(day,2,'0')
  291. return gregDate
  292. Quick Sort
  293. /*====================(Quick sort)====================*/
  294. /* :-D                                              4 */
  295. /* Name.......: QSort                                 */
  296. /*                                                    */
  297. /* Function...: Quick Sort for a stem variable        */
  298. /* Call parm..: No                                    */
  299. /* Returns....: Left-Right span                       */
  300. /*                                                    */
  301. /* Sample call: Call QSort                            */
  302. /*                                                    */
  303. /* Notes......: The elements to sort for must be      */
  304. /*              saved in the stem named so as the     */
  305. /*              stem in this Procedure (in this case  */
  306. /*              "STEM.")                              */
  307. /*              stem.0 must contain the number of     */
  308. /*              elements in stem.                     */
  309. /*                                                    */
  310. /* Changes....: No                                    */
  311. /*                                                    */
  312. /* (C) Copyright Janosch R. Kowalczyk, 1996.          */
  313. /* All rights reserved.                               */
  314. /*====================================================*/
  315. QSort: Procedure Expose stem.
  316. Arg left, right
  317. If left  = '' Then left  = 1
  318. If right = '' Then right = stem.0
  319. If right > left Then Do
  320.   i = left
  321.   j = right
  322.   k = (left+right)%2
  323.   x = stem.k
  324.   Do Until i > j
  325.     Do While stem.i < x; i = i + 1; End
  326.     Do While stem.j > x; j = j - 1; End
  327.     If i <= j Then Do
  328.       xchg = stem.i
  329.       stem.i = stem.j
  330.       stem.j = xchg
  331.       i = i + 1
  332.       j = j - 1
  333.     End
  334.   End
  335.   y = QSort(left,j)
  336.   y = QSort(i,right)
  337. Return right - left
  338. Shell Sort
  339. /*====================(Shell sort)=====================*/
  340. /* :-)                                               5 */
  341. /* Name.......: ShlSort                                */
  342. /*                                                     */
  343. /* Function...: Shell Sort for a stem variable         */
  344. /* Call parm..: No                                     */
  345. /* Returns....: nothing (NULL string)                  */
  346. /*                                                     */
  347. /* Sample call: Call ShlSort                           */
  348. /*                                                     */
  349. /* Notes......: The elements to sort for must be       */
  350. /*              saved in the stem named so as the      */
  351. /*              stem in this Procedure (in this case   */
  352. /*              "STEM.")                               */
  353. /*              stem.0 must contain the number of      */
  354. /*              elements in stem.                      */
  355. /*                                                     */
  356. /* Changes....: No                                     */
  357. /*                                                     */
  358. /* (C) Copyright Janosch R. Kowalczyk, 1996.           */
  359. /* All rights reserved.                                */
  360. /*=====================================================*/
  361. ShlSort: Procedure Expose stem.
  362. parts = 3        /* adjust to your necessities ( >1 ) */
  363. Do n = 1 To parts
  364.   incr = 2**n - 1
  365.   Do j = incr + 1 To stem.0
  366.     i = j - incr
  367.     xchg = stem.j
  368.     Do While xchg < stem.i & i > 0
  369.       m = i + incr
  370.       stem.m = stem.i
  371.       i = i - incr
  372.     End /* Do While xchg ... */
  373.     m = i + incr
  374.     stem.m = xchg
  375.   End /* Do j = incr ... */
  376. End /* Do n = 1 ... */
  377. Return ''
  378. Gregorian to julian date
  379. /*=============(Gregorian to julian date)==============*/
  380. /*                                                  9  */
  381. /* Name.......: G2J                                    */
  382. /*                                                     */
  383. /* Function...: translates gregorian date to the       */
  384. /*              julian date                            */
  385. /* Call parm..: gregorian date in format yyyy.mm.dd    */
  386. /* Returns....: julian date (yyyy.ddd)                 */
  387. /*                                                     */
  388. /* Syntax.....: julDate = G2J(yyyy.mm.dd)              */
  389. /*                                                     */
  390. /* Changes....: No                                     */
  391. /*                                                     */
  392. /* (C) Copyright Janosch R. Kowalczyk, 1996.           */
  393. /* All rights reserved.                                */
  394. /*=====================================================*/
  395. G2J: Procedure
  396. Arg gregDat
  397. year = SubStr(gregDat,1,4)
  398. mon  = SubStr(gregDat,6,2) + 0 /* To delete leading zero */
  399. day  = SubStr(gregDat,9,2)
  400. mon.1  = 0
  401. mon.2  = 31
  402. mon.3  = 59
  403. mon.4  = 90
  404. mon.5  = 120
  405. mon.6  = 151
  406. mon.7  = 181
  407. mon.8  = 212
  408. mon.9  = 243
  409. mon.10 = 273
  410. mon.11 = 304
  411. mon.12 = 334
  412. If (year // 400 = 0 | (year // 100 > 0 & year // 4 = 0)) & mon > 2 Then
  413.   leap = 1
  414. Else leap = 0
  415. julDay = mon.mon + day + leap
  416. Return year'.'Right(julDay,3,'0')
  417. Square root evolution
  418. /*====================(Square root)====================*/
  419. /* :-)                                               6 */
  420. /* Name.......: SqrRoot                                */
  421. /*                                                     */
  422. /* Function...: Square root evolution for the call     */
  423. /*              parameter                              */
  424. /* Call parms.: Evolution number, precision            */
  425. /* Returns....: Square root                            */
  426. /*                                                     */
  427. /* Syntax.....: sqrt = SqrRoot(number, [precision])    */
  428. /*                                                     */
  429. /* Notes......: precision is the highest possible      */
  430. /*              error for the evaluation.              */
  431. /*              Default Value is 0.00001               */
  432. /*              You are responsible for the valid      */
  433. /*              number value                           */
  434. /*                                                     */
  435. /* Changes....: No                                     */
  436. /*                                                     */
  437. /* (C) Copyright Janosch R. Kowalczyk, 1996.           */
  438. /* All rights reserved.                                */
  439. /*=====================================================*/
  440. SqrRoot: Procedure
  441. Arg number, precision
  442. If Datatype(number) \= 'NUM' Then Return -1
  443. If precision <= 0 | precision > 1 Then precision = 0.00001
  444. sqrt = 1
  445. Do Until Abs(sqrt_old - sqrt) < precision
  446.   sqrt_old = sqrt
  447.   sqrt = (sqrt_old * sqrt_old + number) / (2 * sqrt_old)
  448. End /* Do Until ... */
  449. Return sqrt
  450. Recursive Path Creating
  451. /*=============( Recursive Path Creating )============*/
  452. /*                                                 16 */
  453. /* Name.......: MakePath                              */
  454. /*                                                    */
  455. /* Function...: Create recursive directory path       */
  456. /*                                                    */
  457. /* Call parm..: _destPath  - directory path           */
  458. /*                                                    */
  459. /* Returns....: formated string                       */
  460. /*                                                    */
  461. /* Syntax.....:                                       */
  462. /*    _destPath = MakePath( _destPath )               */
  463. /*                                                    */
  464. /* Changes....: No                                    */
  465. /*                                                    */
  466. /* (C) Copyright Janosch R. Kowalczyk, 1996.          */
  467. /* All rights reserved.                               */
  468. /*====================================================*/
  469. /*---------------(Create Directory Path)--------------*/
  470. MakePath: Procedure
  471. Arg _destPath
  472. _destPath = Strip(_destPath,,'\')
  473. If Pos('\', _destPath) = 0 Then Return _destPath
  474. /*--------------( Check Directory Path )--------------*/
  475. rc = SysFileTree( _destPath, fileList, 'DO' )
  476. If fileList.0 = 0 Then Do
  477.   /*------------(Directory path not exists)-----------*/
  478.   Call MakePath SubStr(_destPath, 1, LastPos('\', _destPath))  
  479.   rc = SysMkDir( _destPath )
  480.   If rc > 0 & rc \= 5 Then
  481.     Say 'Destination directory:' _destPath 'not created. RC=' rc 
  482.   Else 
  483.     Say _destPath 'successful created'
  484. Return _destPath
  485. Delete Directory Path
  486. /*==============( Delete Directory Path )=============*/
  487. /*                                                 17 */
  488. /* Name.......: ErasePath                             */
  489. /*                                                    */
  490. /* Function...: delete directory path                 */
  491. /*                                                    */
  492. /* Call parm..: _erasePath - directory path to be     */
  493. /*              deleted                               */
  494. /*                                                    */
  495. /* Returns....: formated string                       */
  496. /*                                                    */
  497. /* Syntax.....:                                       */
  498. /*    _erasePath = MakePath( _erasePath )               */
  499. /*                                                    */
  500. /* Changes....: No                                    */
  501. /*                                                    */
  502. /* (C) Copyright Janosch R. Kowalczyk, 1996.          */
  503. /* All rights reserved.                               */
  504. /*====================================================*/
  505. /*-------------(Delete Directory Path)------------*/
  506. ErasePath: Procedure
  507. Arg _erasePath 
  508. _erasePath = Strip( _erasePath, , '\' )
  509. Do Until Pos('\', _erasePath) = 0 
  510.   rc = SysRmDir( _erasePath )
  511.   If rc > 0 Then
  512.     Say 'Directory:' _erasePath 'not deleted. RC=' rc 
  513.   Else 
  514.     Say _erasePath 'successful deleted'
  515.   _erasePath = SubStr( _erasePath, 1, LastPos('\', _erasePath) - 1)
  516. Return _erasePath
  517. Remove umlaut characters
  518. /*============( Remove umlaut characters )============*/
  519. /*                                                 14 */
  520. /* Name.......: NoUmlaut                              */
  521. /*                                                    */
  522. /* Function...: Replace umlaut characters with double */
  523. /*              character strings (
  524.  -> ae, 
  525.  -> oe,  */
  526. /*              
  527.  -> ue, 
  528.  -> ss)                     */
  529. /*                                                    */
  530. /* Call parm..: _string - string with umlauts,        */
  531. /*              _upper  - upper case return string    */
  532. /*                        (optional)                  */
  533. /*                                                    */
  534. /* Returns....: translated string                     */
  535. /*                                                    */
  536. /* Syntax.....:                                       */
  537. /*    tranStr = NoUmlaut( uString,['U'] )             */
  538. /*                                                    */
  539. /* Changes....: No                                    */
  540. /*                                                    */
  541. /* Note.......: This function calls the function      */
  542. /*              ReplaceUmlaut                         */
  543. /*                                                    */
  544. /* Author.....: Janosch R. Kowalczyk, 1996.           */
  545. /*====================================================*/
  546. NoUmlaut: Procedure
  547. Parse Arg _string, _upper
  548. /*---------(Replace '
  549. ' by 'ae' 'Ae')-----------*/
  550. _string = ReplaceUmlaut( _string, '
  551. ', 'ae' )
  552. _string = ReplaceUmlaut( _string, '
  553. ', 'Ae' )
  554. /*---------(Replace '
  555. ' by 'oe' 'Oe')-----------*/
  556. _string = ReplaceUmlaut( _string, '
  557. ', 'oe' )
  558. _string = ReplaceUmlaut( _string, '
  559. ', 'Oe' )
  560. /*---------(Replace '
  561. ' by 'ue' 'Ue')-----------*/
  562. _string = ReplaceUmlaut( _string, '
  563. ', 'ue' )
  564. _string = ReplaceUmlaut( _string, '
  565. ', 'Ue' )
  566. /*-------------(Replace '
  567. ' by 'ss')----------------*/
  568. _string = ReplaceUmlaut( _string, '
  569. ', 'ss' )
  570. If Abbrev('UPPER', _upper, 1) = 1 Then
  571.   Return Translate( _string )
  572. Return _string
  573. /*========( Replace a string with an another )========*/
  574. /*                                                14a */
  575. /* Name.......: ReplaceUmlaut                         */
  576. /*                                                    */
  577. /* Function...: Find all occurences of a substring    */
  578. /*              and replace it by an another          */
  579. /*                                                    */
  580. /* Call parm..: _string  - input string,              */
  581. /*              _origin  - substring to be replaced   */
  582. /*              _replStr - replace substring          */
  583. /*                                                    */
  584. /* Returns....: translated string                     */
  585. /*                                                    */
  586. /* Syntax.....:                                       */
  587. /*    tranStr = ReplaceUmlaut( String, origin, repl ) */
  588. /*                                                    */
  589. /* Changes....: No                                    */
  590. /*                                                    */
  591. /* Note.......: This function is called from NoUmlaut */
  592. /*              and was developed for this purpose    */
  593. /*              only. It isn't able to replace sub-   */
  594. /*              strings that have same characters in  */
  595. /*              both - origin and replace string!     */
  596. /*                                                    */
  597. /* Author.....: Janosch R. Kowalczyk, 1996.           */
  598. /*====================================================*/
  599. ReplaceUmlaut: Procedure
  600. Parse Arg _string, _origin, _replStr
  601. /*---( Same characters in the input and output strings )---*/
  602. If Verify( _origin, _replStr, 'M' ) > 0 Then Return _string
  603. /*-----(Replace umlaut by combined characters)-----*/
  604. Do While Pos( _origin, _string ) > 0
  605.   Parse Var _string _prefix_ (_origin) _suffix_
  606.   _string = _prefix_ || _replStr || _suffix_
  607. Return _string
  608. Replace a string
  609. /*========( Replace a string with an another )========*/
  610. /*                                                 15 */
  611. /* Name.......: StrRepl                               */
  612. /*                                                    */
  613. /* Function...: Find all occurences of a substring    */
  614. /*              and replace it by an another          */
  615. /*                                                    */
  616. /* Call parm..: _string  - input string,              */
  617. /*              _origin  - substring to be replaced   */
  618. /*              _replStr - replace substring          */
  619. /*                                                    */
  620. /* Returns....: translated string                     */
  621. /*                                                    */
  622. /* Syntax.....:                                       */
  623. /*  tranStr = ReplaceString(_string,_origin,_replStr) */
  624. /*                                                    */
  625. /* Changes....: No                                    */
  626. /*                                                    */
  627. /* Author.....: Janosch R. Kowalczyk, 1996.           */
  628. /*====================================================*/
  629. StrRepl: Procedure
  630. Parse Arg _string, _origin, _replStr
  631. /*---( Find a substring to replace? )---*/
  632. _lastPos = LastPos( _origin, _string )
  633. If _lastPos > 0 Then Do
  634.   /*---( Get prefix to the substring )---*/
  635.   If _lastPos = 1 Then _prefix = ''
  636.   Else _prefix = SubStr( _string, 1, _lastPos - 1 )
  637.   /*---( Get suffix of the substring )---*/
  638.   _suffix = SubStr( _string, _lastPos + Length( _origin ))
  639.   /*---( Find next substring to replace )---*/
  640.   Return StrRepl( _prefix, _origin, _replStr ) || _replStr || _suffix
  641.   Return _string
  642. Translate To Lower Case
  643. /*=============(Translate To Lower Case)===============*/
  644. /* :-)                                               8 */
  645. /* Name.......: ToLower                                */
  646. /*                                                     */
  647. /* Function...: Translate entired string to lower      */
  648. /*              case                                   */
  649. /* Call parms.: String to translate                    */
  650. /* Returns....: Translated string                      */
  651. /*                                                     */
  652. /* Syntax.....: lowString = ToLower(upperString)       */
  653. /*                                                     */
  654. /* Changes....: No                                     */
  655. /*                                                     */
  656. /* (C) Copyright Janosch R. Kowalczyk, 1996.           */
  657. /* All rights reserved.                                */
  658. /*=====================================================*/
  659. ToLower: Procedure
  660. /*------------(Lower Case entired string)--------------*/
  661. Parse Arg Upper_String
  662. Lowers = XRange('a','z') || '
  663. Uppers = XRange('A','Z') || '
  664. Return Translate(Upper_String, Lowers, Uppers)
  665. Read file into a stem
  666. /*==============(Read file into a stem)==============*/
  667. /* :-)                                OS/2 Only!!! 7 */
  668. /* Name.......: FileRead                             */
  669. /*                                                   */
  670. /* Function...: Read file into a stem                */
  671. /*                                                   */
  672. /* Call parms.: File name                            */
  673. /*              Number of lines                      */
  674. /* Returns....: Number of lines                      */
  675. /*                                                   */
  676. /* Sample call: lines = FileRead('read.me')            */
  677. /*                                                   */
  678. /* Changes....: No                                   */
  679. /*                                                   */
  680. /* (C) Copyright Janosch R. Kowalczyk, 1996.         */
  681. /* All rights reserved.                              */
  682. /*===================================================*/
  683. FileRead: Procedure Expose stem.
  684. Arg fileName, lines
  685. If lines = '' Then
  686.   lines = Stream( fileName, 'C', 'Query Size' )
  687. status = Stream( fileName, 'C', 'Query Exists' )
  688. If status  \= '' Then Do
  689.   Do i = 1 To lines while Lines( fileName ) > 0
  690.     stem.i = LineIn( filename )
  691.   End
  692.   stem.0 = i - 1
  693.   status = Stream( fileName, 'C', 'Close' )
  694. Else Do
  695.   stem.1 = 'FileRead Error. File' fileNeme' not found'
  696.   stem.0 = 1
  697. Return stem.0
  698. Greatest common divisor
  699. /*=============( Greatest common divisor )============*/
  700. /*                                                 18 */
  701. /* Name.......: EuclidGCD                             */
  702. /*                                                    */
  703. /* Function...: Get greatest common divisor (Euclids  */
  704. /*              algorithm)                            */
  705. /* Call parm..: _counter                              */
  706. /*              _denuminator                          */
  707. /* Returns....: gcd                                   */
  708. /*                                                    */
  709. /* Syntax.....:                                       */
  710. /*    gcd = EuclidGCD( _counter, _denuminator )       */
  711. /*                                                    */
  712. /* Changes....: No                                    */
  713. /*                                                    */
  714. /* (C) Copyright Janosch R. Kowalczyk, 1997.          */
  715. /* All rights reserved.                               */
  716. /*====================================================*/
  717. /*--------------(Greatest common divisor)-------------*/
  718. EuclidGCD: Procedure
  719. Arg _counter, _denuminator
  720. Do Until _counter = 0
  721.   If _counter < _denuminator Then Do
  722.     _Xchange     = _counter
  723.     _counter     = _denuminator
  724.     _denuminator = _Xchange
  725.   End
  726.   _counter = _counter - _denuminator
  727. Return _denuminator
  728. Cube root evolution
  729. /*====================( Cube root )====================*/
  730. /* :-)                                               7 */
  731. /* Name.......: CubeRoot                               */
  732. /*                                                     */
  733. /* Function...: Cube root evolution for the calling    */
  734. /*              parameter                              */
  735. /* Call parms.: Evolution number, precision (optional) */
  736. /* Returns....: Cube root                              */
  737. /*                                                     */
  738. /* Syntax.....: cbrt = CubeRoot(_digit, [precision])   */
  739. /*                                                     */
  740. /* Notes......: precision is the highest possible      */
  741. /*              error for the evaluation.              */
  742. /*              Default Value is 0.00001               */
  743. /*              You are responsible for the valid      */
  744. /*              number value                           */
  745. /*                                                     */
  746. /* Changes....: No                                     */
  747. /*                                                     */
  748. /* (C) Copyright Janosch R. Kowalczyk, 1997.           */
  749. /* All rights reserved.                                */
  750. /*=====================================================*/
  751. CubeRoot: Procedure
  752. Arg _digit, precision
  753. If Datatype(_digit) \= 'NUM' Then Return -1
  754. If precision <= 0 | precision > 1 Then precision = 0.000001
  755. cbrt = 1
  756. Do Until Abs(cbrt_old - cbrt) < precision
  757.   cbrt_old = cbrt
  758.   cbrt = ( 2 * cbrt_old ** 3 + _digit ) / ( 3 * cbrt_old ** 2 )
  759. End /* Do Until ... */
  760. Return cbrt
  761. Play digital file
  762. /*================(Play digital file)================*/
  763. /* :-)                                OS/2 Only!!! 7 */
  764. /* Name.......: PlayFile                             */
  765. /*                                                   */
  766. /* Function...: Play digital WAV/MID file            */
  767. /*                                                   */
  768. /* Call parms.: File name to play                    */
  769. /* Returns....: RC from the last mciRexx function    */
  770. /*                                                   */
  771. /* Sample call: rc = PlayFile('bach.mid')            */
  772. /*                                                   */
  773. /* Changes....: No                                   */
  774. /*                                                   */
  775. /* (C) Copyright Janosch R. Kowalczyk, 1996.         */
  776. /* All rights reserved.                              */
  777. /*===================================================*/
  778. PlayFile: Procedure
  779. Arg CmdObject
  780. If CmdObject = '' Then Return -1
  781. /*-----------(Initialize mciREXX support)-----------*/
  782. If RxFuncQuery( 'mciRxInit' ) Then Do
  783.   rc = RxFuncAdd( 'mciRxInit', 'MCIAPI', 'mciRxInit' )
  784.   Init_RC = mciRxInit()
  785. loudness = 70 /* % */
  786. /*--------------(Prepare MCI-commands)---------------*/
  787. CmdStr.1 = 'OPEN' CmdObject 'ALIAS W WAIT'
  788. CmdStr.2 = 'SET W TIME FORMAT MS WAIT'
  789. CmdStr.3 = 'SET W AUDIO VOLUME' loudness 'WAIT'
  790. CmdStr.4 = 'PLAY W WAIT'
  791. /*------------(Play digital WAV/MID file)------------*/
  792. Do i = 1 To 4
  793.   /*-----------(Send MCI command strings)------------*/
  794.   rc = mciRxSendString(CmdStr.i, 'retstrvar', '0','0')
  795.   If rc > 0 Then Leave
  796. CmdStr = 'CLOSE W WAIT'
  797. /*--------------(Send MCI command string)--------------*/
  798. rc = mciRxSendString(CmdStr, 'retstrvar', '0','0')
  799. Return rc
  800.