XProfan

WindowTitle "Chandah-sûtra Algorithmus per Exponentiation (Indien, ca. 200 v.Chr)"
' (CL) CopyLeft, Demo-Code by P.Specht, Wien
' Q: https://de.wikipedia.org/wiki/Bin%C3%A4re_Exponentiation
randomize
declare x$,n$,p$
rpt:
Cls rnd(8^8)
Print " Bitte nur natürliche Zahlen > 0 eingeben: "
Print "\n    Basis:",:input x$
print "\n Exponent:",:input n$
print "\n Berechnung corre ";
p$=Chandah(x$,n$)
beep:locate %csrlin,1
print " Chandah-sutra_X^N der Länge ";len(p$);" = \n"
print p$
waitinput
goto "rpt"

proc Chandah :parameters x$,n$

    case (val(n$)=0) and (val(x$)=0):return "-1.unbestimmt"
    case val(x$)=0:return "0"
    ' N in Binärdarstellung wandeln
    ' res=1 : von links nach rechts
    ' 0 wird als Anweisung "Quadriere res" interpretiert,
    ' 1 als "Quadriere res und multipliziere Ergebnis mit 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:print int(100*&Loop/l&);"%";

    endwhile

    return res$

endproc

proc d2b :parameters m$

    declare b$,c%,a%,r%,a$,anz%
    b$=""
    nochmal:
    anz%=len(m$):m$=trim$(m$):r%=0:a$=""

    whileloop len(m$):c%=10*r%+val(mid$(m$,&loop,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$:else :b$="1"+b$:endif

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

        endproc

        proc imult :parameters md$,mr$'Bauernmultiplikation

            Declare sum$:Set("decimals",18)

            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

                return sum$

            endproc

            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