XProfan

WindowTitle "Russische Bauernmultiplikation"
' (CL) Copyleft 2012-08 by P<punkt>Specht<at>gmx.at
' Keine wie auch immer geartete Gewähr!
WindowStyle 1048:Font 2:Randomize
Cls 15790320+rgb(rnd(15),rnd(15),rnd(15))
Declare R#:Struct R=Left&,Top&,Right&,Bottom&:Dim R#,R
External("user32.dll","SystemParametersInfoA",48,0,R#,0)

With R#:Window .Left&,.Top&- .Right&,.Bottom&:EndWith

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

    if md$>mr$:sum$=md$:md$=mr$:mr$=sum$:sum$="":endif

        sum$=""
        case val(right$(md$,1)) mod 2:sum$=mr$

        Repeat

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

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

        print sum$;" "

        if probe!<10^15

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

        else

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

        endif

        WaitInput
        case %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%,manuell%
            manuell%=1
            anz%=len(m$)
            tm&=&gettickcount
            m$=trim$(m$)

            if 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

                if a%>9

                    a%=a%-10
                    r%=1

                endif

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

            endwhile

            case r%=1:a$="1"+a$
            a$=a$+":"
            a$=translate$(a$,"0"," ")
            a$=trim$(a$)
            a$=translate$(a$," ","0")
            a$=left$(a$,len(a$)-1)
            case vz%= -1:a$="-"+a$
            return a$

        endproc

        proc Halbiere : parameters m$

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

            if 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$(a%)
                r%=c%-2*a%

            endwhile

            a$=a$+":"
            a$=translate$(a$,"0"," ")
            a$=trim$(a$)
            a$=translate$(a$," ","0")
            a$=left$(a$,len(a$)-1)
            case 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'last carry
            la&=len(A$):lb&=len(B$):l&=la&

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

                Else :B$=Mkstr$(" ",la&-lb&)+B$:Endif

                Whileloop 0,l&-1

                    i&=l&-&Loop
                    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$=if(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