XProfan

Título de la ventana "Chandah-sûtra Algorithmus para Exponentiation (Indien, ca. 200 v.Chr)"
' (CL) CopyLeft, Demo-Code by P.Pájaro carpintero, Wien
' Q: https://de.wikipedia.org/wiki/Bin%C3%A4re_Exponentiation
randomize
declarar x$,n$,p$
rpt:
Cls rnd(8^8)
Imprimir " Por favor, sólo natürliche Pagar > 0 eingeben: "
Imprimir "\n    Base:",:input x$
imprimir "\n Exponent:",:input n$
imprimir "\n Berechnung se ejecuta ";
p$=Chandah(x$,n$)
beep:locate %csrlin,1
imprimir " Chandah-sutra_X^N el Longitud ";len(p$);" = \n"
imprimir p$
waitinput
goto "rpt"

proc Chandah :parámetros x$,n$

    caso (val(n$)=0) and (val(x$)=0):volver "-1.unbestimmt"
    caso val(x$)=0:volver "0"
    ' N en Binärdarstellung wandeln
    ' res=1 : de links después de rechts
    ' 0 se como Anweisung "Quadriere res" interpretiert,
    ' 1 como "Quadriere res y multipliziere Ergebnis con X "
    var b$=d2b(n$)
    var res$ = "1"
    var l&=len(b$)

    whileloop l&

        res$=imult(res$,res$)

        if mid$(b$,&Loop,1)="1"

            res$=imult(res$,x$)

        endif

        locate %csrlin,22:imprimir int(100*&Loop/l&);"%";

    endwhile

    volver res$

ENDPROC

proc d2b :parámetros m$

    declarar b$,c%,a%,r%,a$,anz%
    b$=""
    otra vez:
    anz%=len(m$):m$=trim$(m$):r%=0:a$=""

    whileloop len(m$):c%=10*r%+val(mid$(m$,&bucle,1))

        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)

        if anz%>0:if r%/2=int(r%/2):b$="0"+b$:más :b$="1"+b$:endif

            m$=a$:goto "nochmal":endif :volver b$

        ENDPROC

        proc imult :parámetros md$,mr$'Bauernmultiplikation

            Declarar sum$:Conjunto("decimals",18)

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

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

                Repeat

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

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

                volver sum$

            ENDPROC

            proc Verdopple

                parámetros m$
                declarar 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$,&bucle,1)
                    c%=val(c$)
                    a%=2*c%+r%
                    r%=0

                    if a%>9

                        a%=a%-10
                        r%=1

                    endif

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

                endwhile

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

            ENDPROC

            proc Halbiere : parámetros m$

                declarar 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$,&bucle,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)
                caso vz%= -1:a$="-"+a$
                volver a$

            ENDPROC

            proc Addiere :parámetros a$,b$

                declarar 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$

                    Más :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)
                    volver s$

                ENDPROC