XProfan

Titre de la fenêtre "Chandah-sûtra Algorithmus pour Exponentiation (indes, ca. 200 v.Chr)"
' (CL) CopyLeft, Demo-Code by P.Specht, vienne
' Q: https://de.wikipedia.org/wiki/suis%C3%A4re_Exponentiation
randomize
declare x$,n$,p$
rpt:
Cls rnd(8^8)
Imprimer " s'il te plaît seulement natürliche payons > 0 eingeben: "
Imprimer "\n    la base:",:input x$
imprimer "\n Exponent:",:input n$
imprimer "\n Berechnung fonctionne ";
p$=Chandah(x$,n$)
beep:locate %csrlin,1
imprimer " Chandah-sutra_X^N qui Longueur ";len(p$);" = \n"
imprimer p$
waitinput
goto "rpt"

proc Chandah :parameters x$,n$

    cas (val(n$)=0) and (val(x$)=0):return "-1.unbestimmt"
    cas val(x$)=0:return "0"
    ' N dans Binärdarstellung wandeln
    ' res=1 : de à gauche à droite
    ' 0 wird comme Anweisung "Quadriere res" interpretiert,
    ' 1 comme "Quadriere res et multipliziere Ergebnis avec X "
    var b$=d2b(n$)
    var res$ = "1"
    var l&=len(b$)

    whileloop l&

        res$=imult(res$,res$)

        si mid$(b$,&Boucle,1)="1"

            res$=imult(res$,x$)

        endif

        locate %csrlin,22:imprimer int(100*&Boucle/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$(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)

        si anz%>0:si r%/2=int(r%/2):b$="0"+b$:d'autre :b$="1"+b$:endif

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

        endproc

        proc imult :parameters md$,mr$'Bauernmultiplikation

            Déclarer sum$:Set("decimals",18)

            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

                return sum$

            endproc

            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