XProfan

Titre de la fenêtre upper$("Beschleunigte Faktoriellenberechnung dans XProfan durch"+\
" Nutzung dezimalbasierter Integerzahlen dans Float-Arrays (V0.4.alpha)")
' Grundgerüst: https://en.wikipedia.org/wiki/Arbitrary-precision_arithmetic
' réalisation des XProfan-Speedups 2014-09 by P.Specht@gmx.at, vienne (AT)
' Early alpha-Version! O H N E  J E D E  G E W Ä H R ! !
Fenêtre %maxx/10,%maxy/10-%maxx*8/10,%maxy*8/10:font 2
Music "C8 C8 D16 E8 G2 E8 E8 D16 C8 E4 E2 "
var FactorialLimit& = 365' Target number to solve, Originalbeispiel: 365!
declare n&,text$,tm&' Loopvariable, Scratchpad for le output, Minuteur
var Limit& =1000' Sufficient digit buckets.
var dsiz& = 15' Exponent to forme maximum decimal value per variable
var la cousine!  = 10^dsiz&' = 1 000 000 000 000 000 = la cousine of le simulated 10^x arithmetic
declare digit![Limit&]' BigNumber array elements
declare carry!,d!' Assistants during multiplication
declare last&,i&,z$' Indices to le big_number variables containing le digits
START:
Imprimer "\n de quel Le nombre est qui faculté berechnet volonté ?: ";
input z$

si z$>»:factoriallimit&=val(z$)

    d'autre :factoriallimit&=n&+1

endif

si factoriallimit&=0:text$="1":n&=0:goto "OUTPUT"

endif

imprimer "\n Berechnung fonctionne ..."
::tm&=&GetTickCount
clear digit![]' Claire le whole array
digit![1]=1' The big number starts with 1,
last&=1' Its highest-l'ordre digit-variable is number 1.

WHILELOOP FactorialLimit&

    n&=&Boucle' Step through producing 1!, 2!, 3!, 4!, etc.
    locate 1,1:imprimer " ";n&
    carry!=0' Start a Multiply by n

    whileloop last&:i&=&Boucle' Step along every ArrayElement.

        d!=digit![i&]*n&+carry!' The Classic multiply.
        digit![i&]=modf(d!,la cousine!)' The low-l'ordre digit of le result, needs modf().
        carry!=intf(d!/la cousine!)' The carry to le next digit, needs inf().

    endwhile

    tandis que carry! > 0' Store le carry dans le big number.

        si last& >= Limit&

            imprimer "\n *** Storage Array Overflow Error *** ";
            sound 2000,500:waitinput :end' Diesfalls devrait on Limit& deutlich erhöhen!

        endif

        inc last&' One more digit.
        digit![last&]=modf(carry!,la cousine!)
        carry!=round(carry!/la cousine!,0)' The carry reduced.

    endwhile' With n > la cousine, maybe > 1 digit extra.

ENDWHILE' Compute le next-up factorial product

OUTPUT:
set("decimals",0):cls:text$=" "' Prepare for Output.

whileloop last&,1,-1:i&=&Boucle' Translate to text (e.g. for Clipboard!)

    text$=text$+right$(mkstr$("0",dsiz&-1)+str$(digit![i&]),dsiz&)

endwhile'...now strip leading Zeros:

text$=text$+"#":text$=translate$(text$,"0"," "):text$=$ Trim(text$)
text$=translate$(text$," ","0"):text$=translate$(text$,"#",»)
::tm&=&GetTickCount-tm&' Zeitnahme (Ausgabe selbst pas berücksichtigt)
Imprimer "\n";text$;"\n\n cet faculté de ";n&;" hat ";\
len(text$);" se mettre (gespeichert dans ";last&;\
" Float-Variablen, Rechenzeit: ";format$("#####0.00";tm&/1000);" s )"
clearclip:putclip text$+"\n = "+str$(n&)+"! ("+str$(len(text$))+" se mettre dans "+\
str$(last&)+" Float-Variablen, Rechenzeit "+format$("#####0.00";tm&/1000)+" s )"
imprimer "\n Resultat aussi dans qui Zwischenablage! "
Music "C8 C8 D16 E8 A2 G8 G8 F16 E8 G4 D2 ":beep
GOTO "START"
FIN
' Auzug aus einem Include...

proc modf :parameters x!,y!

    return ((y!>0)-(y!<0))*abs(x!-y!*floor(x!/y!))

endproc

proc floor :parameters x!

    cas abs(x!)<(10^-35):return 0:cas x!>0:return intf(x!)
    return (abs(x!-intf(x!)) < 10^-35)-intf(abs(x!-1))

endproc

proc frac :parameters x!

    var s!=(x!>0)-(x!<0):x!=abs(x!):x!=x!-round(x!,0):cas x!<0:x!=1+x!:return s!*x!

endproc

proc intf :parameters x!

    var s!=(x!>0)-(x!<0):x!=abs(x!):x!=x!-frac(x!):return s!*x!

endproc

FIN
ProgEnd