XProfan

WindowTitle "Prim & Co. Version für XProfan-11.2 free"
CLS:AppendMenuBar 100,\
"  Auf XProfan-11.2a zurückgequält 2016-08 von P.Specht,Wien; OHNE JEGLICHE GEWÄHR!"

Proc IsPrim :Parameters n&' Feststellen einer Primzahl durch Faktorenzerlegung

    Declare PFactor&[],prim&:PFactor&[]=PrimFac(n&):prim&=SizeOf(PFactor&[]):Return (prim&=1)

EndProc

Proc PrimFac :Parameters n&' Primfaktor-Zerlegung. Zeigt 2·2·3·..

    'Print "PrimFac(123456)=";:WhileLoop 0,SizeOf(PFactor[])-1:Print if(&loop=0,"","·");PFactor[&loop];:EndWhile
    Declare PFac&[],cnt&,diff&,t&:cnt&=0:diff&=2:t&=5
    :Whilenot n& mod 2:PFac&[cnt&]=2:inc cnt&:n&=n& \2:EndWhile
    :Whilenot n& mod 3:PFac&[cnt&]=3:inc cnt&:n&=n& \3:EndWhile
    :While sqr(t&)<=n&:Whilenot n& mod t&:PFac&[cnt&]=t&:inc cnt&:n&=n& \t&:EndWhile
    t&=t&+diff&:diff&=6-diff&:EndWhile:Case n&>1:PFac&[cnt&]=n&:Return PFac&[]

EndProc

Proc findInX :Parameters fac&:Var erg!=-1:Case SizeOf(x&[])<1:Return erg!

    :WhileLoop 0,SizeOf(x&[])-1:If x&[&loop]=fac&:erg!=&loop:Break:EndIf:EndWhile:Return erg!

EndProc

Proc addInX :Parameters fac&,fcnt&:Declare n&:n&=findInX(fac&)

    If n&=-1:Inc cnt&:x&[cnt&]=fac&:xc&[cnt&]=fcnt&:Else :Case xc&[n&]<fcnt&:xc&[n&]=fcnt&:EndIf

    EndProc

    Proc sum:var erg!=0

        If SizeOf(x&[])>0:erg!=x&[0]^xc&[0]

            :WhileLoop 1,SizeOf(x&[])-1:erg!=erg!*x&[&loop]^xc&[&loop]:EndWhile
            EndIf:Return erg!

        EndProc

        Proc pfc :Parameters n&:Declare fac&,fcnt&,diff&,t&:diff&=2:t&=5:fac&=2:fcnt&=0

            :Whilenot n& mod 2:inc fcnt&:n&=n& \2:EndWhile:Case fcnt&>0:addInX(2,fcnt&)
            fac&=3:fcnt&=0:Whilenot n& mod 3:inc fcnt&:n&=n& \3:EndWhile:Case fcnt&>0:addInX(3,fcnt&)

            While sqr(t&)<=n&:fcnt&=0:Whilenot n& mod t&:inc fcnt&:n&=n& \t&:EndWhile

                Case fcnt&>0:addInX(t&,fcnt&) : t&=t&+diff&:diff&=6-diff&
                EndWhile:Case n&>1:addInX(n&,1)

            EndProc

            Proc kgV'Kleinstes gemeinsames Vielfaches. Erlaubt 2 bis 9 Parameter:

                '  Print "kgV(12,8)=";format$("%d",kgV(12,8))
                '  Print "kgV(62,36)=";format$("%d",kgV(62,36))
                Declare erg!,cnt&,x&[],xc&[]:cnt&=-1

                Select %PCount

                    CaseOf 9:Parameters a9&,b9&,c9&,d9&,e9&,f9&,g9&,h9&,i9&

                    pfc a9&:pfc b9&:pfc c9&:pfc d9&:pfc e9&:pfc f9&:pfc g9&:pfc h9&:pfc i9&:Return sum()

                    CaseOf 8:Parameters a8&,b8&,c8&,d8&,e8&,f8&,g8&,h8&

                    pfc a8&:pfc b8&:pfc c8&:pfc d8&:pfc e8&:pfc f8&:pfc g8&:pfc h8&:Return sum()

                    CaseOf 7:Parameters a7&,b7&,c7&,d7&,e7&,f7&,g7&

                    pfc a7&: pfc b7&: pfc c7&: pfc d7&: pfc e7&: pfc f7&: pfc g7&:Return sum()

                    CaseOf 6:Parameters a6&,b6&,c6&,d6&,e6&,f6&

                    pfc a6&: pfc b6&: pfc c6&: pfc d6&: pfc e6&: pfc f6&:Return sum()

                    CaseOf 5:Parameters a5&,b5&,c5&,d5&,e5&:pfc a5&: pfc b5&: pfc c5&: pfc d5&: pfc e5&:Return sum()

                    CaseOf 4:Parameters a4&,b4&,c4&,d4&:pfc a4& : pfc b4& : pfc c4& : pfc d4&:Return sum()

                    CaseOf 3:Parameters a3&,b3&,c3&:pfc a3& : pfc b3& : pfc c3&:Return sum()

                    CaseOf 2:Parameters a2&,b2&:pfc a2&: pfc b2&:Return sum()

                    EndSelect:Return 0.0

                EndProc

                Proc ggT2 :Parameters a&,b&' Größter gemeinsamer Teiler, 2 Parameter

                    Declare t& :if b&>a&:t&=a&:a&=b&:b&=t&:endif:Casenot b&:Return a& : Return ggT2(b&,a& mod b&)

                EndProc

                Proc ggT' Größter gemeinsamer Teiler. 1 bis 9 Parameter

                    Select %PCount

                        CaseOf 9:Parameters a9&,b9&,c9&,d9&,e9&,f9&,g9&,h9&,i9&

                        Return ggT2(ggT2(ggT2(ggT2(ggT2(ggT2(ggT2(ggT2(a9&,b9&),c9&),d9&),e9&),f9&),g9&),h9&),i9&)

                        CaseOf 8:Parameters a8&,b8&,c8&,d8&,e8&,f8&,g8&,h8&

                        Return ggT2(ggT2(ggT2(ggT2(ggT2(ggT2(ggT2(a8&,b8&),c8&),d8&),e8&),f8&),g8&),h8&)

                        CaseOf 7:Parameters a7&,b7&,c7&,d7&,e7&,f7&,g7&

                        Return ggT2(ggT2(ggT2(ggT2(ggT2(ggT2(a7&,b7&),c7&),d7&),e7&),f7&),g7&)

                        CaseOf 6:Parameters a6&,b6&,c6&,d6&,e6&,f6&

                        Return ggT2(ggT2(ggT2(ggT2(ggT2(a6&,b6&),c6&),d6&),e6&),f6&)

                        CaseOf 5:Parameters a5&,b5&,c5&,d5&,e5&

                        Return ggT2(ggT2(ggT2(ggT2(a5&,b5&),c5&),d5&),e5&)

                        CaseOf 4:Parameters a4&,b4&,c4&,d4&:Return ggT2(ggT2(ggT2(a4&,b4&),c4&),d4&)

                        CaseOf 3:Parameters a3&,b3&,c3&:Return ggT2(ggT2(a3&,b3&),c3&)

                        CaseOf 2:Parameters a2&,b2&:Return ggT2(a2&,b2&)

                        CaseOf 1:Parameters a1&:Return a1&

                        EndSelect:Return 0

                    EndProc

                    Proc kgV_aus_ggT :var erg!=0

                        '' Statt Abstreich-Methode kann kgV auch mittels "Summe durch ggT" ermittelt werden. Bsp.:
                        '  Print "kgV_aus_ggT(53667,459486)=";format$("%d",kgV_aus_ggT(53667,459486))
                        '  Print "kgV_aus_ggT(62,36)=";format$("%d",kgV_aus_ggT(62,36))

                        Select %PCount

                            CaseOf 9:Parameters a9&,b9&,c9&,d9&,e9&,f9&,g9&,h9&,i9&

                            erg!=a9&*b9&*c9&*d9&*e9&*f9&*g9&*h9&*i9& / ggT(a9&,b9&,c9&,d9&,e9&,f9&,g9&,h9&,i9&)

                            CaseOf 8:Parameters a8&,b8&,c8&,d8&,e8&,f8&,g8&,h8&

                            erg!=a8&*b8&*c8&*d8&*e8&*f8&*g8&*h8& / ggT(a8&,b8&,c8&,d8&,e8&,f8&,g8&,h8&)

                            CaseOf 7:Parameters a7&,b7&,c7&,d7&,e7&,f7&,g7&

                            erg!=a7&*b7&*c7&*d7&*e7&*f7&*g7& / ggT(a7&,b7&,c7&,d7&,e7&,f7&,g7&)

                            CaseOf 6:Parameters a6&,b6&,c6&,d6&,e6&,f6&

                            erg!=a6&*b6&*c6&*d6&*e6&*f6& / ggT(a6&,b6&,c6&,d6&,e6&,f6&)

                            CaseOf 5:Parameters a5&,b5&,c5&,d5&,e5&:erg!=a5&*b5&*c5&*d5&*e5& / ggT(a5&,b5&,c5&,d5&,e5&)

                            CaseOf 4:Parameters a4&,b4&,c4&,d4&:erg!=a4&*b4&*c4&*d4& / ggT(a4&,b4&,c4&,d4&)

                            CaseOf 3:Parameters a3&,b3&,c3&:erg!=a3&*b3&*c3& / ggT(a3&,b3&,c3&)

                            CaseOf 2:Parameters a2&,b2&:erg!=a2&*b2& / ggT(a2&,b2&)

                            CaseOf 1:Parameters a1&:erg!=a1&

                            EndSelect:Return erg!

                        EndProc

                        ' Hauptprogramm:
                        Print "\n\n T E S T :"
                        declare x&,y&,i&,j&,e&,path$,limit&,limit$
                        declare PFactor&[]
                        print "\n\n kgV(53667,459486)=";format$("%d",kgV(53667,459486))
                        print " kgV_aus_ggt(53667,459486)=";format$("%d",kgV_aus_ggT(53667,459486))
                        print " ----------------------------------------------------------------------"
                        x&=62 : y&=36 :print "\n ggT2(";x&;",";y&;")=",ggT(x&,y&)
                        x&=1023 : y&=99 :print " ggT2(";x&;",";y&;")=",ggT(x&,y&)
                        x&=1071 : y&=1029 :print " ggT2(";x&;",";y&;")=",ggT(x&,y&)
                        print " -------"
                        print "\n ggT(1023,99,1071,1029)=",ggT(1023,99,1071,1029)
                        print " ggT(15400,7875,3850)=",ggT(15400,7875,3850)
                        font 2:print "\n ----------------------------------------------------------"
                        66EA1F72BEC94EAEA8A150F6BC904FA2:
                        Print "\n Auf PRIM zu testende Zahl: ";:input limit$

                        if val(limit$)>(2^31-1):print "Zu groß!":sound 800,100:goto "66EA1F72BEC94EAEA8A150F6BC904FA2":endif

                            limit&=val(limit$)
                            locate %csrlin-1,45:print if(isPrim(limit&)," <<< ist PRIM!"," <<< ist nicht prim.")
                            print "\n ---------------------- [Start] ----------------------------"
                            Print "\n Zerlegungen werden in Datei auf dem Desktop geschrieben."
                            Print "\n Bis zu welcher Obergrenze sollen die Faktoren ermittelt werden? "
                            print "\n Limit = ";:input limit&:print
                            path$=getenv$("USERPROFILE")+"\DESKTOP\Primfaktoren.txt":e&=%IOResult
                            Assign #1,path$:e&=%IOResult
                            Rewrite #1:e&=%IOResult

                            if e&:Print "Problem beim Schreiben der Datei "+path$:waitinput:sound 1000,200:End:Endif

                                Print  "\n Daten werden soeben geschrieben nach: ";path$
                                case limit&<=3000:Print  "\n Primfaktoren (2.."+str$(limit&)+")"
                                Print #1,"Datei der Primfaktoren von 2 bis "+str$(limit&)
                                'WhileLoop 20000,limit&

                                WhileLoop 2,limit&

                                    case limit&<=3000:Print  "\n Faktoren(";&loop;"): ";
                                    Print #1,"\n(";&loop;") ";
                                    PFactor&[]=PrimFac(&loop)
                                    i&=0 : j&=SizeOf(PFactor&[])

                                    While i&<j&

                                        case limit&<=3000:Print  "" + if(i&=0,"","·"); PFactor&[i&];
                                        Print #1,"" + if(i&=0,"","·"); PFactor&[i&];
                                        Inc i&

                                    EndWhile

                                    Clear PFactor&[]
                                    case limit&<=3000:Print  ""+if(IsPrim(&loop)," PRIM","");
                                    Print #1,""+if(IsPrim(&loop)," PRIM","");

                                EndWhile

                                Print #1,"\nEOF":e&=%IOResult
                                Close #1:e&=%IOResult
                                Print  "\n Daten wurden geschrieben nach: ";path$:sound 2000,90
                                Print "\n Ende":WaitInput:End