XProfan

Titre de la fenêtre "Russische Bauernmultiplikation"
' (CL) Copyleft 2012-08 by P<punkt>Specht<at>gmx.at
' aucun cependant geartete Gewähr!
Fenêtre Style 1048:Font 2:Randomiser
Cls 15790320+rgb(rnd(15),rnd(15),rnd(15))
Déclarer R#:Struct R=Left&,Top&,Right&,Bottom&:Faible R#,R
Externe("user32.dll","SystemParametersInfoA",48,0,R#,0)

With R#:Fenêtre .Left&,.Top&- .Right&,.Bottom&:EndWith

    Dispose R#
    Déclarer md$,mr$,sum$,probe!
    Set("decimals",18)
    Nochmal:
    imprimer "\n Multiplikand  =",:input md$
    imprimer "\n Multiplikator =",:input mr$
    imprimer "\n Produkt       =",
    probe!=val(md$)*val(mr$)

    si md$>mr$:sum$=md$:md$=mr$:mr$=sum$:sum$=»:endif

        sum$=»
        cas val(right$(md$,1)) mod 2:sum$=mr$

        Repeat

            md$ = Halbiere(md$)
            mr$ = Verdopple(mr$)
            cas val(right$(md$,1)) mod 2 : sum$ = Addiere(sum$,mr$)

        Until val(left$(md$,2))=0

        imprimer sum$;" "

        si probe!<10^15

            imprimer "\n Probe (Float) = ";probe!

        d'autre

            imprimer "\n Probe (Float)= ";format$("%e",probe!)

        endif

        WaitInput
        cas %csrlin>35:Cls 15790320+rgb(rnd(15),rnd(15),rnd(15))
        goto "Nochmal"

        proc Verdopple

            parameters m$
            declare c$,c%,a%,r%,a$,tm&,vz%,anz%,manuel%
            manuel%=1
            anz%=len(m$)
            tm&=&gettickcount
            m$=$ Trim(m$)

            si left$(m$,1)="-"

                vz%=-1
                m$=mid$(m$,2,len(m$)-1)

            endif

            a$=»
            r%=0

            whileloop len(m$),1,-1

                c$ = mid$(m$,&loop,1)
                c%=val(c$)
                a%=2*c%+r%
                r%=0

                si a%>9

                    a%=en%-10
                    r%=1

                endif

                a$=str$(en%)+a$

            endwhile

            cas r%=1:a$="1"+a$
            a$=a$+»
            a$=translate$(a$,"0"," ")
            a$=$ Trim(a$)
            a$=translate$(a$," ","0")
            a$=left$(a$,len(a$)-1)
            cas vz%= -1:a$="-"+a$
            return a$

        endproc

        proc Halbiere : parameters m$

            declare c$,c%,a%,r%,a$,tm&,vz%,anz%,manuel%
            anz%=len(m$)
            tm&=&gettickcount
            m$=$ Trim(m$)

            si left$(m$,1)="-"

                vz%= -1
                m$=mid$(m$,2,len(m$)-1)

            endif

            r%=0
            a$=»

            whileloop len(m$)

                c$ = mid$(m$,&loop,1)
                c%=10*r%+val(c$)
                a%=c%\2
                a$=a$+str$(en%)
                r%=c%-2*a%

            endwhile

            a$=a$+»
            a$=translate$(a$,"0"," ")
            a$=$ Trim(a$)
            a$=translate$(a$," ","0")
            a$=left$(a$,len(a$)-1)
            cas vz%= -1:a$="-"+a$
            return a$

        endproc

        proc Addiere : parameters a$,b$

            declare S$,la&,lb&,l&,a&,b&,c&,s&,i&,si$,carry&,lc&
            a&=0:b&=0:S$=»:S&=0:c&=0:carry&=0:lc&=0'charge carry
            la&=len(A$):lb&=len(B$):l&=la&

            Si lb&>la&:l&=lb&:A$=Mkstr$(" ",lb&-la&)+A$

                D'autre :B$=Mkstr$(" ",la&-lb&)+B$:Endif

                Whileloop 0,l&-1

                    i&=l&-&Boucle
                    a&=val(Mid $(A$,i&,1))
                    b&=val(Mid $(B$,i&,1))
                    c&=carry&+a&+b&
                    s&=c& mod 10
                    carry&= c& \ 10
                    lc&=carry&
                    si$=str$(s&):s$=si$+s$

                Endwhile

                s$=si(lc&,str$(lc&)," ")+s$
                s$=$ S+»
                s$=translate$(s$,"0"," ")
                s$=$ Trim($ S)
                s$=translate$(s$," ","0")
                s$=left$(s$,len($ S)-1)
                return s$

            ENDPROC