Fakultätsberechnung mit voller Stellenzahl

[p. specht]

Fakultäten auf volle Stellenzahl berechnen
===========================
Vorwarnung: Der Algorithmus ("Multiplikation zu Fuß") hat nahezu quadratische Laufzeit! Mit ProfComp compiliert, braucht 100! 234 ms, 500! 8485 ms, 1000! 39750 ms, für 2000! bereits 176889 ms = 2 min 57 sec. Und 2500! langweilt dann schon mit 285013 ms = 4 min 45 sec, die 9131 Stellen von 3000! brauchen gar 419766 ms = 7 min. (Aus Fadesse: 4000! mit 12674 Stellen ziemlich genau 13 min). Um 10000! auszuprobieren (dafür wäre die reservierte Stellenzahl ausgelegt) ist mir meine Lebenszeit zu schade (Schätzung: ~4 1/2 Tage)... Das Ding schreit nach Assembler !
Gruss

WindowTitle "Fakultätsberechnung mit voller Stellenzahl"
'Source: http://en.wikipedia.org/wiki/Arbitrary-precision_arithmetic
'Translated to XProfan 11.2a by P. Specht (D) Demoware 2011-08 f
'Demo only. No warranty whatsoever. Ohne jegliche Gewähr!

Def &Limit 35661                  'Ausreichende Anzahl Stellen
Def &Base  10                     'The base of the simulated arithmetic.
Def &FactorialLimit 10000         'Max number to solve
Declare Digit&[&Limit]            'The big number.
Declare carry&, d&, n&            'Assistants during multiplication.
Declare last&, i&                 'Indices to the big number's digits.
Declare text$[&Limit]             'Scratchpad for the output.
Declare tdigit$[15]               'The Number Signs in that Base System
tdigit$[0]="0":tdigit$[1]="1":tdigit$[2]="2":tdigit$[3]="3"
tdigit$[4]="4":tdigit$[5]="5":tdigit$[6]="6":tdigit$[7]="7"
tdigit$[8]="8":tdigit$[9]="9":tdigit$[10]="A":tdigit$[11]="B"
tdigit$[12]="C":tdigit$[13]="D":tdigit$[14]="E":tdigit$[15]="F"
Declare Fact&
Declare Dauer&

Font 2 : Randomize
Window 0,0 - %MaxX/2,%MaxY-50

Eingabe:
cls rnd(8^8)

Print " Fakultät berechnen von n = ";:input Fact&
if Fact&=0
  Print: Print " 0! = 1  (per Definition)"
  WaitInput
  goto "Eingabe"
elseif Fact&<0
  Print " Fakultät hier nur von natürlichen, also positiven Zahlen!"
  Print " Danke für's testen!"
  WaitInput
  goto "Finis"
elseIf Fact& > &FactorialLimit
  print " Für den reservierten Speicher zu groß, bitte max. ";&FactorialLimit
  Beep
  Waitinput
  Goto "Eingabe"
Endif
Print " Berechnung von n! ..." : Print

'BEGIN  Arbitrary Precision Algorithm
dauer&=&GetTickCount
Clear Digit&[]                    'Clear the whole array.
Digit&[1]=1                       'The big number starts with 1,
last&=1                           'Its highest-order digit is number 1.
WHILELOOP Fact&                   'Step through producing 1!, 2!, 3!, 4!, etc. 
  n&=&Loop
  carry&=0                        'Start a multiply by n.
  WhileLoop last&                 'Step along every digit.
    i&=&Loop
    d&=digit&[i&] * n& + carry&   'Classic multiply.
    digit&[i&]=d& mod &Base       'The low-order digit of the result.
    carry&=d& \ &Base             'The carry to the next digit.
  EndWhile
  While carry& > 0                'Store the carry in the big number.            
    if last& >= &Limit
      print "Array Overflow!"
      Beep
      WaitInput
      END
    endif
    last&=last& + 1                'One more digit.
    digit&[last&]=carry& mod &Base 'Placed.
    carry& = carry& \ &Base        'The carry reduced.
  Endwhile                         'With n > Base, maybe > 1 digit extra.

Case n&<Fact& : continue         'Else Output
    dauer&=&GetTickCount-dauer&
    
    Print
    Print " ";n&;"! = ";      'Translate from binary to text:
    whileloop last&,1,-1              'Arabic numerals put the low order last, so
      print tdigit$[digit&[&Loop]];   'we have to reverse the order.
      case %pos > Width(%hwnd) /10.26 : print
       if %csrlin > (Height(%hwnd)-40)/20
         print " ...weiter mit Taste! "
         WaitInput
         CLS rgb(200,200,200)
         print "...";
       endif 
    endwhile
    Print  
    Print " Diese Zahl hat "; last&; " Stellen, berechnet in "; dauer&; " ms "

ENDWHILE                           'Upward to the next multiplication
WaitInput
Goto "Eingabe"
Finis:
END