XProfan

WindowTitle "RENCONTRES-Zahl, DERANGEMENT und SUBFAKULTÄT"
' (CL)Copyleft 2011ff P.Specht für Profaner
' Versuch einer Umsetzung des Wikipedia-Artikels betr. Rencontres-Zahl
' in XProfan 11.2a, KEINE GEWÄHR - No warranty whatsoever!
Font 2
declare p!,n!,k!,Ren!,i&
Weiter:
cls
Print " In der KOMBINATORIK versteht man unter der RENCONTRES-Zahl   "
print " (französisch für 'Begegnungen') die mit D(n;k) bezeichnete   "
print " Anzahl jener PERMUTATIONEN einer Menge n unterscheidbarer    "
print " Elemente, bei der genau k Elemente ihren ursprünglichen bzw. "
print " einen bestimmten gewünschten Platz einnehmen (und n-k nicht)."
print " Ren=D(n;k)=n!/k!*SUM[i=0..(n-k)](-1)^i/i!=(n OVR k)*D(n-k;0) "
print "                                                              "
print " Für den Fall, dass KEINES der n Elemente seinen Platz ein-   "
print " nimmt bzw. 'wiederfindet', ergibt sich als Sonderfall die    "
print " Formel für die Zahl möglicher DERANGEMENTS oder 'Totalver-   "
print " setzungen' aller n Elemente zu  !n = 'SUBFAKULTÄT von n'     "
print " nach der Formel:  !n = D(n;0) = n! * SUM[i=0..n](-1)^i/i!    "
' print " {Interessant: lim[n..+Inf](SUM[i=0..n](-1)^i/i!))= 1/exp(1)} "
Print "                                                              "
Print " Bsp: Anzahl n der zu permutierenden Elemente eingeben: ";:input n!

if n!>15

    print " Wegen oberer Integer-Grenze bitte nur Zahlen bis 15 - Sorry! "
    WaitInput
    goto "weiter"

endif

print " Prinzipiell gäbe es "; int(fakul(n!)); " Positions-Permutationen."
Print "                                                              "
Print " Wieviele Elemente sollen in Wunschposition stehen?: 0";:input k!
'print "                                                              "
print " Dann gibt es genau ";
Ren!=Rencontres_D(n!,k!)
set("decimals",0)
print Ren!;" solche Permutationen."
set("decimals",3)
print " Die Wahrscheinlichkeit für so eine Stellung ist ";100*Ren!/fakul(int(n!));"%"
set("decimals",0)
WaitInput
goto "Weiter"

Proc Rencontres_D : parameters n!,k!

    var n&=int(n!)
    var k&=int(k!)
    var p!=1

    whileLoop k&+1,n&

        p!=p!*&Loop

    EndWhile

    var s!=0
    var i&=0

    while i&<=(n&-k&)

        s! = s! + (1.0-2.0*(i& mod 2)) / fakul(i&)
        inc i&

    endwhile

    'print "Vorfaktor: ";p!
    'print "    Summe: ";s!
    return p! * s!

EndProc

Proc fakul

    parameters p&
    var prd!=1
    case p&<1 : p&=1
    case p&>169 :prd! = -1
    case prd!<0: goto "back"

    whileloop p&,1,-1

        prd!=prd!*&Loop

    endwhile

    back:
    return prd!

EndProc