XProfan

WindowTitle upper$("Beschleunigte Faktoriellenberechnung in XProfan durch"+\
" Nutzung dezimalbasierter Integerzahlen in Float-Arrays (V0.4.alpha)")
' Grundgerüst: https://en.wikipedia.org/wiki/Arbitrary-precision_arithmetic
' Realisierung des XProfan-Speedups 2014-09 by P.Specht@gmx.at, Wien (AT)
' Early alpha-Version! O H N E  J E D E  G E W Ä H R ! !
Window %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 the output, Timer
var Limit& =1000' Sufficient digit buckets.
var dsiz& = 15' Exponent to form maximum decimal value per variable
var Base!  = 10^dsiz&' = 1 000 000 000 000 000 = Base of the simulated 10^x arithmetic
declare digit![Limit&]' BigNumber array elements
declare carry!,d!' Assistants during multiplication
declare last&,i&,z$' Indices to the big_number variables containing the digits
START:
Print "\n Von welcher Zahl soll die Fakultät berechnet werden ?: ";
input z$

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

    else :factoriallimit&=n&+1

endif

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

endif

print "\n Berechnung läuft ..."
::tm&=&GetTickCount
clear digit![]' Clear 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:print " ";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 result, needs modf().
        carry!=intf(d!/Base!)' The carry to the next digit, needs inf().

    endwhile

    while carry! > 0' Store the carry in the big number.

        if last& >= Limit&

            print "\n *** Storage Array Overflow Error *** ";
            sound 2000,500:waitinput :end' Diesfalls müsste man 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:text$=" "' Prepare for Output.

whileloop last&,1,-1:i&=&Loop' 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 nicht berücksichtigt)
Print "\n";text$;"\n\n Diese Fakultät von ";n&;" hat ";\
len(text$);" Stellen (gespeichert in ";last&;\
" Float-Variablen, Rechenzeit: ";format$("#####0.00";tm&/1000);" s )"
clearclip:putclip text$+"\n = "+str$(n&)+"! ("+str$(len(text$))+" Stellen in "+\
str$(last&)+" Float-Variablen, Rechenzeit "+format$("#####0.00";tm&/1000)+" s )"
print "\n Resultat auch in der Zwischenablage! "
Music "C8 C8 D16 E8 A2 G8 G8 F16 E8 G4 D2 ":beep
GOTO "START"
END
' 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!

    case abs(x!)<(10^-35):return 0:case 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):case 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

END
ProgEnd