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