XProfan

Window Title upper$("Beschleunigte Faktoriellenberechnung in XProfan durch"+\
" Use dezimalbasierter Integerzahlen in Float-Arrays (V0.4.alpha)")
' Grundgerüst: https://en.wikipedia.org/wiki/Arbitrary-precision_arithmetic
' realization the XProfan-Speedups 2014-09 by P.woodpecker@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 shape maximum decimal value by variable
var Base!  = 10^dsiz&' = 1 000 000 000 000 000 = Base of the simulated 10^x arithmetic
declare digit![Limit&]' BigNumber aray elements
declare carry!,d!' Assistants during multiplication
declare last&,i&,z$' Indices to the big_number variables containing the digits
START:
Print "\n From which Number is The Fakultät accounts go ?: ";
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 runs ..."
::tm&=&GetTickCount
clear digit![]' Clear the whole aray
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' net curtain the carry in the big number.

        if last& >= Limit&

            print "\n *** Storage aray Overflow Error *** ";
            sound 2000,500:waitinput :end' Diesfalls should one Limit& explicit raise!

        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)+st$(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 (spending self not berücksichtigt)
Print "\n";text$;"\n\n These Fakultät of ";n&;" has ";\
len(text $);" to put (stored in ";last&;\
" Float-variables, Rechenzeit: ";stature$("#####0.00";tm&/1000);" s )"
clearclip:putclip Text$+"\n = "+st$(n&)+"! ("+st$(len(text $))+" to put in "+\
st$(last&)+" Float-variables, Rechenzeit "+stature$("#####0.00";tm&/1000)+" s )"
print "\n result too in the Clipboard! "
Music "C8 C8 D16 E8 A2 G8 G8 F16 E8 G4 D2 ":beep
GOTO "START"
END
' Auzug a 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