XProfan

Título de la ventana upper$("Beschleunigte Faktoriellenberechnung en XProfan durch"+\
" Nutzung dezimalbasierter Integerzahlen en Float-Arrays (V0.4.alpha)")
' Grundgerüst: https://en.wikipedia.org/wiki/Arbitrary-precision_arithmetic
' Realisierung des XProfan-Speedups 2014-09 by P.Pájaro carpintero@gmx.at, Wien (AT)
' Early alpha-Versión! O H N E  J E D E  G E W Ä H R ! !
Ventana %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!
declarar n&,texto$,tm&' Loopvariable, Scratchpad for the output, Temporizador
var Limit& =1000' Sufficient digit buckets.
var dsiz& = 15' Exponent to form maximum decimal value por variable
var Base!  = 10^dsiz&' = 1 000 000 000 000 000 = Base of the simulated 10^x arithmetic
declarar digit![Limit&]' BigNumber array elements
declarar carry!,d!' Assistants during multiplication
declarar last&,i&,z$' Indices to the big_number variables containing the digits
START:
Imprimir "\n Von welcher El número es el Fakultät berechnet voluntad ?: ";
input z$

if z$>"":factoriallimit&=val(z$)

    más :factoriallimit&=n&+1

endif

if factoriallimit&=0:texto$="1":n&=0:goto "OUTPUT"

endif

imprimir "\n Berechnung se ejecuta ..."
::tm&=&GetTickCount
clear digit![]' Claro the whole array
digit![1]=1' The big number starts with 1,
last&=1' Its highest-order digit-variable is number 1.

WHILELOOP FactorialLimit&

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

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

        d!=digit![i&]*n&+carry!' The Classic multiply.
        digit![i&]=modf(d!,Base!)' The low-order digit of the resultado, needs modf().
        carry!=intf(d!/Base!)' The carry to the next digit, needs inf().

    endwhile

    mientras que carry! > 0' Store the carry en the big number.

        if last& >= Limit&

            imprimir "\n *** Storage Array Overflow Error *** ";
            sound 2000,500:waitinput :end' Diesfalls debería uno Limit& deutlich erhöhen!

        endif

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

    endwhile' With n > Base, maybe > 1 digit extra.

ENDWHILE' Compute the next-up factorial product

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

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

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

endwhile'...now strip leading Zeros:

text$=texto$+"#":texto$=translate$(texto$,"0"," "):texto$=trim$(texto$)
text$=translate$(texto$," ","0"):texto$=translate$(texto$,"#","")
::tm&=&GetTickCount-tm&' Zeitnahme (Edición incluso no berücksichtigt)
Imprimir "\n";text$;"\n\n Diese Fakultät de ";n&;" ha ";\
len(texto$);" Stellen (gespeichert en ";last&;\
" Float-Variables, Rechenzeit: ";format$("#####0.00";tm&/1000);" s )"
clearclip:putclip texto$+"\n = "+str$(n&)+"! ("+str$(len(texto$))+" Stellen en "+\
str$(last&)+" Float-Variables, Rechenzeit "+format$("#####0.00";tm&/1000)+" s )"
imprimir "\n Resultat auch en el Zwischenablage! "
Music "C8 C8 D16 E8 A2 G8 G8 F16 E8 G4 D2 ":beep
GOTO "START"
FIN
' Auzug de una Incluir...

proc modf :parámetros x!,y!

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

ENDPROC

proc floor :parámetros x!

    caso abs(x!)<(10^-35):volver 0:caso x!>0:volver intf(x!)
    volver (abs(x!-intf(x!)) < 10^-35)-intf(abs(x!-1))

ENDPROC

proc frac :parámetros x!

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

ENDPROC

proc intf :parámetros x!

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

ENDPROC

FIN
ProgEnd