home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 18 REXX / 18-REXX.zip / kzr_0899.zip / prim.CMD < prev    next >
OS/2 REXX Batch file  |  1998-08-10  |  4KB  |  176 lines
  1. /* REXX-Programm PPrim.CMD        */          
  2. /* Die Dateien "kzr.INF" und "krz.CMD   */
  3. /* befinden sich im selben Verzeichnis. */
  4. Call RxFuncAdd 'SysLoadFuncs', RexxUtil, 'SysLoadFuncs'
  5. Call SysLoadFuncs
  6. signal on halt name PgmEnd
  7.   
  8. Pfd=SysSearchPath("PATH", "kzr.cmd")
  9. lp=LastPos("\", Pfd)
  10. Pfd=DelStr(Pfd, 1+lp)
  11.  
  12. ab=34
  13. Parse upper arg x
  14. say
  15. /* Zwischenräume aus dem String  x  entfernen */
  16. do forever
  17.   lzw=Pos(" ", x)
  18.   if lzw = 0 then leave
  19.   x=DelStr(x,lzw,1)
  20. end
  21.  
  22. ND=length(x)+6
  23. Numeric Digits ND 
  24.  
  25. if (length(x)= 0) then
  26. do
  27.   "@ start /PM /MAX view.exe" Pfd||"KZR.INF Primfaktoren"
  28.   EXIT
  29. end
  30.  
  31. if DataType(x, 'W')<>1 | x<1 | Pos(",", x)>0 then
  32. do
  33.   Call Color 1,white
  34.   say"Sie haben keine positive ganze Zahl eingegeben !"
  35.   Beep(444, 200); Beep(628,300)
  36.   signal PgmEnd
  37. end
  38.  
  39. call Charout,"   Die Zahl, die in Primfaktoren zerlegt werden soll,"; say
  40. call Charout,"   ist:"; say
  41. Call Color 1,Cyan
  42. call Charout,"       " x
  43. Call Color 0,white; say; say
  44. say Insert("Primfaktor    Exponent",' ',ab, ,); say
  45.  
  46. y=x; z=1; erg=1 
  47. do while v>0 
  48.   T=GWurz(y)+1
  49.   do N=2 to T
  50.     v=0
  51.     do while (y//N=0 & y>=N)
  52.       y=y/N
  53.       z=z*N
  54.       v=v+1
  55.     end
  56.     
  57.     if v>0 then
  58.     do
  59.       erg=erg*N**v 
  60.       lz=ab-length(N)
  61.       NN=Insert(N,' ',lz, ,)
  62.       lv=4-length(v)
  63.       vv=Insert(v,' ',lv, ,)
  64.       call Color 1,white
  65.       say"          "NN"        "vv
  66.       Call Color 0,white
  67.     end
  68.     if v>0 then leave
  69.   end
  70. end
  71.   
  72. if y<>1 then
  73. do
  74.   erg=erg*y**1 
  75.   lz=ab-length(y)
  76.   NN=Insert(y,' ',lz, ,)
  77.   call Color 1,white
  78.   say"          "NN"           1"
  79.   Call Color 0,white
  80. end
  81. Beep(120, 300)
  82. say
  83.  
  84. if erg==y then
  85. do
  86.   erg=erg*y**1 
  87.   call Charout,"   Die eingegebene Zahl "; say
  88.   Call Color 1,cyan
  89.   call Charout,"                        " x  
  90.   Call Color 0,white
  91.   call Charout,","; say; say 
  92.   call Charout,"   die in ihre Primfaktoren zerlegt werden soll, " 
  93.   Call Color 1,white
  94.   call Charout,"ist selbst eine Primzahl."
  95.   Beep(444, 200); Beep(628,300)
  96.   say             
  97.   signal PgmEnd
  98. end
  99.  
  100. if erg<>1 then
  101. do
  102.   call Charout,"   Der Wert des Produktes,"; say
  103.   call Charout,"   dessen Faktoren die einzelnen Potenzen "
  104.   Call Color 1,green
  105.   call Charout,'"Primfaktor hoch Exponent"'  
  106.   Call Color 0,white
  107.   call Charout," sind,"; say 
  108.   call Charout,"   ist:"; say 
  109.   Call Color 1,cyan
  110.   call Charout,"        "erg
  111.   say             
  112.   signal PgmEnd
  113. end
  114.  
  115. PgmEnd:
  116. say
  117. Call Color 0,white
  118. EXIT
  119.  
  120.  
  121. /* Prozedur GWurz für die Berechnung der zweiten Wurzel */
  122. /* aus positiven ganzen Zahlen.                         */
  123. /* GWurz liefert als Ergebnis nur ganze Zahlen.         */
  124. GWurz:
  125.    Procedure
  126.    arg x
  127.    ND=40
  128.    numeric digits ND+3
  129.  
  130.    n=0
  131.    do while x>100
  132.      x=x/100
  133.      n=n+1
  134.    end
  135.  
  136.    y=1; t=x/y
  137.    do while abs(y-t) > y*10**(-ND-2)
  138.      y=(y+t)/2
  139.      t=x/y
  140.    end
  141.  
  142.    u=y*10**n
  143.    numeric digits ND
  144.    return(Format(u,,0))
  145.  
  146.  
  147. Raus:
  148.   say
  149.   Call Color 1,red
  150.   call Charout,"   Kein Ergebnis !"; say; say
  151.   call Color 1,white
  152.   Call Charout,"   Mindestens einer der Primfaktoren"
  153.   Call Charout," der von Ihnen eingegebenen Zahl"; say; say
  154.   call Color 1,Cyan
  155.   call Charout,"            " x; say; say
  156.   call Color 1,white
  157.   Call Charout,"   ist offenbar so groß, daß die Zerlegung"
  158.   Call Charout," dieser Zahl in ihre Primfaktoren"; say
  159.   Call Charout,"   mit einer Interpretersprache wie REXX"
  160.   Call Charout," viel zu lange dauern würde."; say
  161.   Beep(444, 200); Beep(628,300)
  162.   signal PgmEnd
  163.  
  164.  
  165. /***************************** ANSI-Prozeduren ******************************/
  166.  
  167.  
  168. Color:     /* Call Color <Attr>,<ForeGround>,<BackGround>                */  
  169. Procedure  /* Attr=1 -> HIGH;  Attr=0 -> LOW; Attr only for ForeGround ! */
  170. arg A,F,B   
  171. CLRS = "BLACK RED GREEN YELLOW BLUE MAGENTA CYAN WHITE"
  172. A=strip(A); if length(A)==0 then A=0    
  173. F=strip(F); if length(F)==0 then F=WHITE
  174. B=strip(B); if length(B)==0 then B=BLACK
  175. return CHAROUT(,D2C(27)||"["A";"WORDPOS(F,CLRS)+29";"WORDPOS(B,CLRS)+39"m")
  176.