XProfan

WindowTitle "Algorithm ZS1: Erzeugung einer vollständigen, "+\
"revers-geordneten Partitionierung ohne Wiederholung"
'Q: Antoine Zoghbi, Ivan Stojmenovic: Fast Algorithms for Generating Integer Partitions
'   published in: "International Journal of Computer Mathematics, 70, 1998, 319-332."
'S: [url]https://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.42.1287&rep=rep1&type=pdf[/url]
'T: Translation to XProfan 11.2a 2016-07ff by P.Specht, Vienna/Austria
'No Warranty whatsoever! Ohne jedwede Gewähr! Rechtslage ungeprüft.
WindowStyle 24:Window 0,0-%maxx,%maxy:font 2:randomize
declare z$,z&,tm&,cnt&,bench&:   Rept:
Cls:Print "\n  ZAHL, die partitioniert werden soll (0: Ende; Minuszahl: Nur Zeitmessung)? : ";
z$="":input z$:bench&=0:case val(z$)<0:bench&=1:z&=rnd(30):case z$>"":z&=abs(val(z$))

if z&=0:print "\n  Ergebnis: Leere Menge.\n\n  Programm wird beendet! ":beep:waitinput 4000:END:endif

    case bench&:print "\n  Messung corre ..."
    tm&=&GetTickCount
    cnt& = Algorithm_ZS1(z&,bench&)
    print "\n  ";cnt&;" Partitionen erzeugt."

    if bench& : tm&=&GetTickCount-tm&

        print "\n  Laufzeit per n = ";z&;": ";tm&;" [ms] bzw. ";tm&/1000;" [s] bzw. ";tm&/60000;" [min]"

    endif

    sound 2000,60
    waitinput
    Goto "Rept"
    END

    Proc Algorithm_ZS1 :parameters n&,bench&

        declare x&[n&],i&,m&,h&,r&,t&,cnt&

        whileloop n&

            x&[&loop]=1

        endwhile

        x&[1]=n&
        m&=1:h&=1
        cnt&=1
        casenot bench&:print "\n>>> ";x&[1]'show or do something useful

        while x&[1]<>1

            if x&[h&]=2'Easy case, applies often

                ' h is the index of the last part of partition which is greater than 1
                ' m is the number of parts.
                inc m&:x&[h&]=1:dec h&

            else

                r&=x&[h&]-1
                t&=m&-h&+1
                x&[h&]=r&

                while t&>=r&

                    inc h&
                    x&[h&]=r&
                    t&=t&-r&

                endwhile

                if t&=0

                    m&=h&

                else

                    m&=h&+1

                    if t&>1

                        inc h&:x&[h&]=t&

                    endif

                endif

            endif

            inc cnt&

            ifnot bench&:print "    ";:whileloop m&:print x&[&Loop],:endwhile:print:endif

                'or do something useful with the result line

            endwhile

            return cnt&

        EndProc

WindowTitle "Algorithm ZS2: Erzeugung einer vollständigen, "+\
"AUFSTEIGEND geordneten Partitionierung ohne Wiederholung"
'Q: Antoine Zoghbi, Ivan Stojmenovic: Fast Algorithms for Generating Integer Partitions
'   published in: "International Journal of Computer Mathematics, 70, 1998, 319-332."
'S: https://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.42.1287&rep=rep1&type=pdf
'T: Translation to XProfan 11.2a 2016-07ff by P.Specht, Vienna/Austria
'No Warranty whatsoever! Ohne jedwede Gewähr!
'
'Test your results against "Partition Numbers" of https://oeis.org/A000041
'00>>> 1, 1, 2, 3, 5,   7, 11, 15, 22, 30,
'10>>> 42, 56, 77, 101, 135,   176, 231, 297, 385, 490,
'20>>> 627, 792, 1002, 1255, 1575,   1958, 2436, 3010, 3718, 4565,
'30>>> 5604, 6842, 8349, 10143, 12310,   14883, 17977, 21637, 26015, 31185,
'40>>> 37338, 44583, 53174, 63261, 75175,   89134, 105558, 124754, 147273,173525
'50>>> ...
WindowStyle 24:Window 0,0-%maxx,%maxy:randomize:font 2
declare z$,z&,tm&,cnt&,bench&:   Rept:
Cls:Print "\n  ZAHL, welche partitioniert werden soll (0: Ende; Minuszahl: Nur Zeitmessung)? : ";
z$="":input z$:bench&=0:case val(z$)<0:bench&=1:z&=rnd(30):case z$>"":z&=abs(val(z$))

if z&=0:print "\n  Ergebnis: Leere Menge.\n\n  Programm wird beendet! ":beep:waitinput 4000:END:endif

    case bench&:print "\n  Messung corre ..."
    tm&=&GetTickCount
    cnt& = Algorithm_ZS2(z&,bench&)
    tm&=&GetTickCount-tm&
    print "\n  ";cnt&;" Partitionen erzeugt."

    if bench&:print "\n  Laufzeit per n = ";z&;": ";tm&;" [ms] bzw. ";tm&/1000;" [s] bzw. ";tm&/60000;" [min]"

        endif :sound 2000,60:waitinput
        Goto "Rept"
        END

        Proc Algorithm_ZS2 :parameters n&,bench&

            declare x&[n&],i&,m&,h&,r&,j&,cnt&

            if n&=1:print "       ";1 :cnt&=1:goto "ZS2_exit":endif

                :whileloop n&:x&[&loop]=1:endwhile
                cnt&=1

                ifnot bench&:print "\n>>> ";:whileloop n&:print x&[&Loop],:endwhile:print

                endif'or do something useful with the result line

                x&[0]=-1:x&[1]=2:m&=n&-1:h&=1:inc cnt&

                ifnot bench&:print "    ";:whileloop m&:print x&[&Loop],:endwhile:print

                endif'or do something useful with the result line

                while x&[1]<>n&

                    if (m&-h&)>1

                        inc h&
                        x&[h&]=2
                        dec m&

                    else

                        j&=m&-2

                        While x&[j&]=x&[m&-1]

                            x&[j&]=1
                            dec j&

                        endwhile

                        h&=j&+1
                        x&[h&]=x&[m&-1]+1
                        r&=x&[m&]+x&[m&-1]*(m&-h&-1)
                        x&[m&]=1
                        case (m&-h&)>1:x&[m&-1]=1
                        m&=h&+r&-1

                    endif

                    inc cnt&

                    ifnot bench&:print "    ";:whileloop m&:print x&[&Loop],:endwhile:print:endif

                        'or do something useful with the result line

                    endwhile

                    ZS2_exit:
                    return cnt&

                EndProc

WindowTitle "Teilungsmöglichkeiten zählen":WindowStyle 24:cls
Print "\n Dieses Programm zählt die möglichen Teilungen von N Elementen"
print "\n per zulässige Teilungsgrößen von 1 bis M Elementen.\n"
declare n&,m&,count!
nochmal:
clear n&,m&,count!
print "\n    Gesamtlänge N = ";:input n&
print "\n Max. Teillänge M = ";:input m&
print "\n Count ergibt ";format$("%g",Count_partitions(n&,m&));" mögliche Teilungen!\n"
waitinput:cls:goto "nochmal"

proc count_partitions :parameters n&,m&

    if n&=0:return 1

    elseif n&<0:return 0

    elseif m&=0:return 0

    else

        return count_partitions(n&-m&,m&)+count_partitions(n&,m&-1)

    endif

Endproc