Squares

General FreeBASIC programming questions.
dafhi
Posts: 1339
Joined: Jun 04, 2005 9:51

Re: Squares

Postby dafhi » Oct 26, 2018 0:30

working on my newest random number generator, i thought i'd try a multiplier of 4, which produces a cool reflection pattern

Code: Select all

function CSG_ii as double '' 2018 Sep 17
 
  '' produces a cool pattern
  const as ulongint mul = 4
 
  static as ulongint a, state = 0
 
  a += 1 - (state = 0)
 
  state = state shl 57 or state shr 7
  state = mul * state xor a
 
  return state / 2^64
End function


#undef rnd
#define rnd csg_ii

#include "pathtracer.bas" ' https://www.freebasic.net/forum/viewtopic.php?f=7&t=25232


function CSG as double
   
  const mul = 6364136223846793005ull '' Knuth's LCG
  const add = 1442695040888963407ull
 
  static as ulongint state = 1
 
  state = mul * (state shr 9) + add
 
  return (state and 4294967295) / 4294967296

End function

#undef rnd
#define rnd csg


'#include "util.bas"
#Ifndef floor   '' http://www.freebasic.net/forum/viewtopic.php?p=118633
  #Define floor(x) (((x)*2.0-0.5)shr 1)
  #define ceil(x) (-((-(x)*2.0-0.5)shr 1))
#EndIf

function round(in as double, places as ubyte = 0) as string
  dim as integer mul = 10 ^ places
  return str( floor( in * mul +.5 ) / mul )
End Function
' ------- util

' ------- material demo

const BASE_RAD = 50

dim shared as tMatte mat
 
sub sphere_as_ground(byref sce as scene, col as v3=type(1,1,1), k as single=.1, fresnel as single=0)
  mat.quick_solid col, k, fresnel, 0
  sce.add_sphere 0,-BASE_RAD,0, BASE_RAD, sce.add_material(mat.refl, mat.refr, mat.em)
End sub

sub create_lights(byref sce as scene, num as integer=3, brightness as single=1, size_min as single = 1, y as single = .5, size_variance_mult as single = 2.5)
  var size_avg = size_min * (1+size_variance_mult) / 2
  for i as integer = 1 to num
    var a = i / num
    mat.quick_light hsv(a*6,.2,1)*brightness
    var rad = size_min + rnd * size_variance_mult*size_min, dist=.8, angle = twopi*a
    dim as v3 v=type( dist*cos(angle), y, dist*sin(angle) )
    sce.add_sphere v.x,v.y,v.z, rad, sce.add_material(mat.refl, mat.refr, mat.em)
  next
End Sub


sub Main
 
  var seed = 6

  for i as long = 1 to seed
    dim as single f = rnd
  Next
 
  dim as imagevars buf:  buf.screen_init 800, 600
  dim as imagevars buf2: buf2.create buf.w,buf.h
 
  dim as scene    sce0, sce1, sce2
 
  var scale=.333/1.0:  sce0.dimensions buf.w*scale, buf.w*scale
  sce0.render_target buf2
 
  with *sce0.pobjects
    .bgcol = type(.7,.6,.55)*.6
   
    .cam.zoom = 1.15
   
    var pos_scalar = .7
    .cam.o.z = -2.0 * pos_scalar
    .cam.o.y = .45 * pos_scalar
    .cam.o.x = -.8
  end with
  sce0.look_at .02, .06, 0
 
  dim as tracer   tr

  ' scene ===========
 
  '                                    k, fresnel
  sphere_as_ground sce0, hsv(0,0,.8), .3, .5
 
  mat.quick_solid hsv(0,0,.8)       ,.01, .5
  'sce0.obj(0).mat_layer sce0.add_material(mat.refl, mat.refr, mat.em), .3
 
  '                   num, brightness, size_min,    y, size_vari_mult
  create_lights sce0,   5,         30,     .010,  .35
 
  sce1 = sce0
  sce1.pobjects = @sce1.objects
 
  sce2 = sce0
  sce2.pobjects = @sce2.objects
 
 
  ' material tester ===========
 
  var rad = .1, y=rad+.0
 
  var hue = 4, k = 1/25, fres = 0f, refr_amt = 0f, ior = 1f
  mat.quick_solid hsv(hue,.3, 1), k, fres, refr_amt
  sce0.add_sphere 0,y,0, rad, sce0.add_material(mat.refl, mat.refr, mat.em, ior)
 
  mat.refl.fresnel = 1
  sce1.add_sphere 0,y,0, rad, sce1.add_material(mat.refl, mat.refr, mat.em, ior)

  '' layered
  k = 0
  mat.quick_solid hsv(hue, .4, 1), k, mat.refl.fresnel, refr_amt
  sce2.add_sphere 0,y,0, rad, sce2.add_material(mat.refl, mat.refr, mat.em, ior), .7 ''layer strength
 
  refr_amt = 1:  ior = 1.22
  mat.quick_solid hsv(.5, .3, 1), k,                 0, refr_amt, 0 '' refr_amt, light
  sce2.pobjects->obj(sce2.pobjects->ub_obj).mat_layer sce2.add_material(mat.refl, mat.refr, mat.em, ior), .5 ''layer strength
 
  var border=2

  dim as double t=timer, t_next = t, t0=t
  'randomize
 
  while 1
   
    locate 1,1 ''print statements:  upper left corner
   
    tr.render sce2
    tr.render sce0
    tr.render sce1
    t = Timer

    if t >= t_next then
      var xw = sce0.w+border, x0=xw*0, x1=xw*1, x2=xw*2, y2=sce0.h+31:  y=sce0.h+1
      var y4 = y2 - 10
     
      sce0.image_out x0, 0
      sce0.image_out x0, y2,,, true
      sce1.image_out x1, 0
      sce1.image_out x1, y2,,, true
      sce2.image_out x2, 0
      sce2.image_out x2, y2,,, true
     
      put (0,0), buf2.im, pset
      draw string (x0, y), "reflection"
      var matref = sce1.pobjects->obj(sce1.pobjects->ub_obj).msv(0).id
      draw string (x1, y), "fresnel = " & str(sce1.pobjects->mat_(matref).o.refl.fresnel)
      draw string (x2, y), "k = " & str(mat.refl.k) & ", + new mat layer"
      draw string(0,y4), "importance map"
      if sce0.pixel_size <= 4 then windowtitle "frame: " & str(sce0.frame) & " time: " & round( (t-t0)/60, 2 ) & " min"
      t_next = t + 1.3 / sce0.pixel_size ^ 1.7
    endif
    sleep 1
   
    if inkey <> "" then exit while
  wend

  draw string(0,sce0.h+11), "done!"
  windowtitle "done! " & round( (t-t0)/60, 2 ) & " minutes"
 
  sleep
 
end sub

Main
Last edited by dafhi on Oct 30, 2018 1:29, edited 1 time in total.
albert
Posts: 5676
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Oct 28, 2018 18:08

A little saying i came up with:

dinner & kinner , groiner & joiner
unless she's a virgin then
you got to kinner before you dinner and joiner before you groiner..
albert
Posts: 5676
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Oct 30, 2018 1:26

I came up with a faster way to do the "averager" multiplier. ( stepping by 18's )
I'll post it , in another couple days , when i get it written..
albert
Posts: 5676
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 01, 2018 23:40

@Richard

For my Averager:
Whats the fastest way to tell if a double precision number has a .5 at the end ?
Richard
Posts: 3013
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Postby Richard » Nov 02, 2018 1:06

@Albert.
You have no choice but to convert the number to decimal using the st = Str( dp ) function, then parse the string.
You need to better specify the input range and data format to get a better answer.
albert
Posts: 5676
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 02, 2018 2:11

@Richard

I think i got it!!!

could i do:

ints = int( (n1 + n2) / 2 )
fracts = frac( (n1 + n2) / 2 )
??
I'd like to do it , in one operation.. instead of two separate ops...

Code: Select all


screen 19

dim as double n1 = 121
dim as double n2 = 120

dim as integer n3 = int( (n1+n2) / 2 ) 
dim as double n4 = frac( (n1+n2) / 2 )
 
print "n1 = " ; n1
print "n2 = " ; n2
print
print "n3 = " ; n3
print "n4 = " ; n4

sleep
end

Richard
Posts: 3013
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Postby Richard » Nov 02, 2018 5:19

If you keep everything as integers you can do;
Dim as Integer n1, n2, sum, fract, avg
sum = n1 + n2
fract = sum And 1 ' test if odd, fract is 1 if half
avg = sum shr 1 ' which divides by two
albert
Posts: 5676
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 13, 2018 3:18

I invented to new words for the dictionary..

plevin = @#&|$ long enter vessel many up&down
jevin = @#&|$ enter vessel many up&down

plevin , jevin , heaven

I'm still working on the averager, it'll be another week or so to write it...
I'll incorporate your above advice...
still got to wrap my head around it..
dodicat
Posts: 6491
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » Nov 13, 2018 22:36

Ending in .5

Code: Select all

 


#define ending(n) ((n)-.000001)\1 <> ((n)+.000001)\1


for n as double=1 to 10000 step .31
    if ending(n/20) then print using "####.#"; n/20
next

sleep
albert
Posts: 5676
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Dec 03, 2018 3:53

@Dodicat

I got my averager working with 1's and 2's but it's returning wrong for 3's

Code: Select all


DECLARE FUNCTION multiplier_7(byref num1 as string, byref num2 as string) as string
Declare Function divide(n1 As String,n2 As String,decimal_places As integer,dpflag As String="s") As String

DECLARE Function minus(NUM1 As String,NUM2 As String) As String
Declare Function       plus( NUMber1 As String  ,  NUMber2 As String ) As String
Declare Function half(fl As String) As String


declare function convert_to_pointers( n as string ) as string
declare function make_equal( n as string) as string
declare function less_great ( n1 as string , n2 as string) as string

screen 19

dim as longint size = 3  ' works with 1 and 2 but not 3 (????)
do
   
    dim as string num1
    for a as longint =  1 to size step 1
        num1+=str(int(rnd*10))
    next
    if left(num1,1) = "0" then mid(num1,1,1) = str(int(rnd*9)+1)
   
    dim as string num2
    for a as longint =  1 to size step 1
        num2+=str(int(rnd*10))
    next
    if left(num2,1) = "0" then mid(num2,1,1) = str(int(rnd*9)+1)
   
    if num2 > num1 then swap num1 , num2
    if len(num2) > len(num1) then swap num1 , num2
    if len(num2) = len(num1) then if val(left(num2,1)) > val(left(num1,1)) then swap num1,num2
    '==========================================================
    'declare vars
    '==========================================================
   
    dim as string test = num2
   
    dim as string l_bot =  string( len(num2) , "0" )
    dim as string l_avg = string( len(num2) , "0" )
    dim as string l_top =  string( len(num2) , "9" )
   
    '==========================================================
    'make all var strings a multiple of 18 digits
    '==========================================================
    test = make_equal( test )
   
    l_bot  = make_equal( l_bot )
    l_avg = make_equal( l_avg )
    l_top  = make_equal( l_top )

    '==========================================================
    'convert the numeric strings to use pointers
    '==========================================================
    test = convert_to_pointers( test )
   
    l_bot = convert_to_pointers( l_bot )
    l_avg = convert_to_pointers( l_avg )
    l_top = convert_to_pointers( l_top )
   
    dim as string char
    dim as ulongint loops = 0
   
    do
       
        loops+=1
       
        l_avg = string( len(l_avg) , chr(0) ) 
        dim as ubyte l_val = 0
        dim as ubyte l_frac = 0
        dim as ubyte ptr lt_ptr  = cptr( ubyte ptr , strptr( l_top ) )
        dim as ubyte ptr la_ptr = cptr( ubyte ptr , strptr( l_avg ) )
        dim as ubyte ptr lb_ptr = cptr( ubyte ptr , strptr( l_bot ) )
            for a as longint = 1 to len( l_avg) step 1
               
                if l_frac = 1 then *(la_ptr)+= 5
               
                l_val = ( *lt_ptr + *lb_ptr )
                l_frac = l_val and 1
               
                *la_ptr+= ( l_val shr 1 )
               
                if *(la_ptr) >= 10 then *(la_ptr)-= 10 : *(la_ptr-1)+= 1
               
                lt_ptr+=1
                la_ptr+=1
                lb_ptr+=1
            next
            if l_frac = 1 then *(la_ptr-1)+= 1
            if *(la_ptr-1) >= 10 then *(la_ptr-1)-= 10 : *(la_ptr-2)+= 1
       
        char = less_great( l_avg , test )
       
        print test , l_avg , char
       
        if inkey = chr(27) then exit do
       
        if char = ">" then l_top = l_avg
        if char = "<" then l_bot = l_avg
        if char = "=" then exit do
     
     loop
   
    dim as ubyte ptr lavg_ptr = cptr( ubyte ptr , strptr(l_avg) )
    dim as string l_ans = ""
    for a as longint = 1 to len(l_avg) step 1
            l_ans+= right(string(1,"0") +  str( *lavg_ptr ) , 1 )
            lavg_ptr+=1
    next
   
    'dim as string my_answer = ""
    'dim as string real_answer = multiplier_7( num1 , num2 )
    'real_answer = left( real_answer , len(real_answer)-1 )
   
    dim as string difference = minus( l_ans , num2 )
   
    print
    'print "n1    = "  ; num1
    print "n2    = "  ; num2
    print "l_ans = " ; l_ans , difference
    print
    'print "real ans = "  ; real_answer
    'print "my  ans  = " ; my_answer
    'print
    'print "diff        =  " ; difference
    'print
    print "loops = " ; loops
   
    if l_ans <> num2 then sleep
   
    if inkey = " " then sleep
   
loop until inkey = chr(27)

sleep
end
'==================================================
'==================================================
function less_great ( n1 as string , n2 as string) as string
        dim as string char = "="
        if n1 = n2 then return char
        dim as ubyte ptr ubp1 = cptr( ubyte ptr , strptr(n1) )
        dim as ubyte ptr ubp2 = cptr( ubyte ptr , strptr(n2) )
        for a as longint = 1 to len(n1) step 1
            if *ubp1 > *ubp2 then char = ">" : exit for
            if *ubp1 < *ubp2 then char = "<" : exit for
            ubp1+=1
            ubp2+=1
        next
        return char
end function
'==================================================
'==================================================
function convert_to_pointers( n as string ) as string
   
    dim as string n1 = n
    dim as string n2
    dim as ubyte ptr ubp
    dim as ushort val1
    dim as ushort len_1
   
    n2 = string(len(n1) , chr(0))
    ubp = cptr(ubyte ptr,strptr(n2))
    len_1 = 0
    for a as longint = 0 to len(n1)-1 step 1
        val1 =  (n1[a]-48)
        *ubp = val1
        ubp+=1
        len_1+=1
    next
    return n2
end function
'==================================================
'==================================================
function make_equal( n as string) as string
    dim as string n1 = n
    dim as string str1
    dim as ulongint dec1
    do
        str1 = str( len(n1) / 1)
        dec1 = instr(1,str1,".")
        if  dec1 <> 0 then n1 = "0" + n1
    loop until dec1 = 0
    return n1
end function
'==================================================
'==================================================
Function divide(n1 As String,n2 As String,decimal_places As integer,dpflag As String="s") As String
          Dim As String number=n1,divisor=n2
          dpflag=lcase(dpflag)
          'For MOD
          dim as integer modstop
          if dpflag="mod" then
              if len(n1)<len(n2) then return n1
              if len(n1)=len(n2) then
                  if n1<n2 then return n1
                  end if
              modstop=len(n1)-len(n2)+1
              end if
          if dpflag<>"mod" then
     If dpflag<>"s"  Then dpflag="raw"
     end if
        Dim runcount As integer
        '_______  LOOK UP TABLES ______________
        Dim Qmod(0 To 19) As Ubyte
        Dim bool(0 To 19) As Ubyte
        For z As Integer=0 To 19
    Qmod(z)=(z Mod 10+48)
    bool(z)=(-(10>z))
Next z
Dim answer As String   'THE ANSWER STRING 

'_______ SET THE DECIMAL WHERE IT SHOULD BE AT _______
Dim As String part1,part2
#macro set(decimal)
#macro insert(s,char,position)
If position > 0 And position <=Len(s) Then
part1=Mid$(s,1,position-1)
part2=Mid$(s,position)
s=part1+char+part2
End if
#endmacro
insert(answer,".",decpos)
  answer=thepoint+zeros+answer
If dpflag="raw" Then
    answer=Mid(answer,1,decimal_places)
    End if
#endmacro
'______________________________________________
'__________ SPLIT A STRING ABOUT A CHARACTRR __________
Dim As String var1,var2
    Dim pst As integer
      #macro split(stri,char,var1,var2)
    pst=Instr(stri,char)
    var1="":var2=""
    If pst<>0 Then
    var1=Rtrim(Mid(stri,1,pst),".")
    var2=Ltrim(Mid(stri,pst),".")
Else
    var1=stri
    End if
    #endmacro
   
       #macro Removepoint(s)
       split(s,".",var1,var2)
#endmacro
'__________ GET THE SIGN AND CLEAR THE -ve __________________
Dim sign As String
          If Left(number,1)="-" Xor Left (divisor,1)="-" Then sign="-"
            If Left(number,1)="-" Then  number=Ltrim(number,"-")
            If Left (divisor,1)="-" Then divisor=Ltrim(divisor,"-")
             
'DETERMINE THE DECIMAL POSITION BEFORE THE DIVISION
Dim As integer lennint,lenddec,lend,lenn,difflen
split(number,".",var1,var2)
lennint=Len(var1)
split(divisor,".",var1,var2)
lenddec=Len(var2)

If Instr(number,".") Then
    Removepoint(number)
    number=var1+var2
    End if
If Instr(divisor,".") Then
    Removepoint(divisor)
    divisor=var1+var2
    End if
Dim As integer numzeros
numzeros=Len(number)
number=Ltrim(number,"0"):divisor=Ltrim (divisor,"0")
numzeros=numzeros-Len(number)
lend=Len(divisor):lenn=Len(number)
If lend>lenn Then difflen=lend-lenn
Dim decpos As integer=lenddec+lennint-lend+2-numzeros 'THE POSITION INDICATOR
Dim _sgn As Byte=-Sgn(decpos)
If _sgn=0 Then _sgn=1
Dim As String thepoint=String(_sgn,".") 'DECIMAL AT START (IF)
Dim As String zeros=String(-decpos+1,"0")'ZEROS AT START (IF) e.g. .0009
if dpflag<>"mod" then
If Len(zeros) =0 Then dpflag="s"
end if
Dim As integer runlength
If Len(zeros) Then
     runlength=decimal_places
     answer=String(Len(zeros)+runlength+10,"0")
    If dpflag="raw" Then
        runlength=1
        answer=String(Len(zeros)+runlength+10,"0")
        If decimal_places>Len(zeros) Then
            runlength=runlength+(decimal_places-Len(zeros))
            answer=String(Len(zeros)+runlength+10,"0")
            End If
            End If

Else
decimal_places=decimal_places+decpos
runlength=decimal_places
answer=String(Len(zeros)+runlength+10,"0")
End if
'___________DECIMAL POSITION DETERMINED  _____________

'SET UP THE VARIABLES AND START UP CONDITIONS
number=number+String(difflen+decimal_places,"0")
        Dim count As integer
        Dim temp As String
        Dim copytemp As String
        Dim topstring As String
        Dim copytopstring As String
        Dim As integer lenf,lens
        Dim As Ubyte takeaway,subtractcarry
        Dim As integer n3,diff
       If Ltrim(divisor,"0")="" Then Return "Error :division by zero"   
        lens=Len(divisor)
         topstring=Left(number,lend)
         copytopstring=topstring
        Do
            count=0
        Do
            count=count+1
            copytemp=temp
   
            Do
'___________________ QUICK SUBTRACTION loop _________________             
           
lenf=Len(topstring)
If  lens<lenf=0 Then 'not
If Lens>lenf Then
temp= "done"
Exit Do
End if
If divisor>topstring Then
temp= "done"
Exit Do
End if
End if

  diff=lenf-lens
        temp=topstring
        subtractcarry=0
       
        For n3=lenf-1 To diff Step -1
            takeaway= topstring[n3]-divisor[n3-diff]+10-subtractcarry
            temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n3
        If subtractcarry=0 Then Exit Do
         If n3=-1 Then Exit Do
        For n3=n3 To 0 Step -1
            takeaway= topstring[n3]-38-subtractcarry
             temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            if subtractcarry=0 then exit do
            Next n3
        Exit Do
       
        Loop 'single run
        temp=Ltrim(temp,"0")
        If temp="" Then temp= "0"
            topstring=temp
        Loop Until temp="done"
     ' INDIVIDUAL CHARACTERS CARVED OFF ________________       
        runcount=runcount+1
       If count=1 Then
           topstring=copytopstring+Mid(number,lend+runcount,1)
           Else
       topstring=copytemp+Mid(number,lend+runcount,1)
   End If
       copytopstring=topstring
       topstring=Ltrim(topstring,"0")
       if dpflag="mod" then
       if runcount=modstop then
           if topstring="" then return "0"
           return mid(topstring,1,len(topstring)-1)
           end if
       end if
       answer[runcount-1]=count+47
       If topstring="" And runcount>Len(n1)+1 Then
           Exit Do
           End if
   Loop Until runcount=runlength+1
   
   ' END OF RUN TO REQUIRED DECIMAL PLACES
   set(decimal) 'PUT IN THE DECIMAL POINT
  'THERE IS ALWAYS A DECIMAL POINT SOMEWHERE IN THE ANSWER
  'NOW GET RID OF IT IF IT IS REDUNDANT
       answer=Rtrim(answer,"0")
       answer=Rtrim(answer,".")
       answer=Ltrim(answer,"0")
       If answer="" Then Return "0"
   Return sign+answer
End Function
'===============================================================================
'===============================================================================
Function half(fl As String) As String
    Dim As Ubyte main,carry,temp
    Dim As String sign   , s
    If Instr(fl,".")=0 Then s=fl+".0" Else s=fl+"0"
    If Instr(s,"-") Then sign="-":s=Ltrim(s,"-")
    Dim As String ans=s
    For z As Integer=0 To Len(s)-1
        If s[z]<>46 Then
            temp=(s[z]-48+carry)
            main=temp Shr 1
            carry=(temp And 1) Shl 3 +(temp And 1) Shl 1
            ans[z]=main+48
        End If
    Next z
    If Instr(ans,".") Then ans=Rtrim(ans,"0")
    ans=Rtrim(ans,".")
    ans=Ltrim(ans,"0")
    Return ans
End Function
'===============================================================================
'===============================================================================
'Dodicats plus & Minus functions
'===============================================================================
'===============================================================================
    Function plus(_num1 As String,_num2 As String) As String
        Dim  ADDQmod(0 To 19) As Ubyte
        Dim  ADDbool(0 To 19) As Ubyte
        For z As Integer=0 To 19
            ADDQmod(z)=(z Mod 10+48)
            ADDbool(z)=(-(10<=z))
        Next z
        Var _flag=0,n_=0
        Dim As Ubyte addup=Any,addcarry=Any
        #macro finish()
        answer=Ltrim(answer,"0")
        If _flag=1 Then Swap _num2,_num1
        Return answer
        #endmacro
        If Len(_num2)>Len(_num1) Then
            Swap _num2,_num1
            _flag=1
        End If
        Var diff=Len(_num1)-Len(_num2)
        Var answer="0"+_num1
        addcarry=0
        For n_=Len(_num1)-1 To diff Step -1
            addup=_num2[n_-diff]+_num1[n_]-96
            answer[n_+1]=ADDQmod(addup+addcarry)
            addcarry=ADDbool(addup+addcarry)
        Next n_
        If addcarry=0 Then
            finish()
        End If
        If n_=-1 Then
            answer[0]=addcarry+48
            finish()
            Endif
            For n_=n_ To 0 Step -1
                addup=_num1[n_]-48
                answer[n_+1]=ADDQmod(addup+addcarry)
                addcarry=ADDbool(addup+addcarry)
                If addcarry=0 Then Exit For
            Next n_
            answer[0]=addcarry+48
            finish()
        End Function
'===============================================================================
'===============================================================================
Function minus(NUM1 As String,NUM2 As String) As String
     'Dim As String copyfirstnum=mul_num_1,copysecondnum=mul_num_2
    Dim As Byte swapflag           
    Dim As Long lenf,lens
    Dim sign As String * 1
    'Dim As String part1,part2
    Dim bigger As Byte
     'set up tables
    Dim As Ubyte Qmod(0 To 19)
    Dim bool(0 To 19) As Ubyte

    For z As Integer=0 To 19
        Qmod(z)=cubyte(z Mod 10+48)
        bool(z)=cubyte(-(10>z))
    Next z
    lenf=Len(NUM1)
    lens=Len(NUM2)
    #macro compare(numbers)
        If Lens>lenf Then bigger= -1:Goto fin
        If Lens<lenf Then bigger =0:Goto fin
        If NUM2>NUM1 Then
            bigger=-1
        Else
            bigger= 0
        End If
        fin:
    #endmacro

    compare(numbers)
    If bigger Then
        sign="-"
        Swap NUM2,NUM1
        Swap lens,lenf
        swapflag=1
    Endif
    'lenf=Len(NUM1)
    'lens=Len(NUM2)
    Dim diff As Long=lenf-lens-Sgn(lenf-lens)
    Dim As String one,two,three
    three=NUM1
    two=String(lenf-lens,"0")+NUM2
    one=NUM1
    Dim As Long n2
    Dim As Ubyte takeaway,subtractcarry
    Dim As Ubyte ten=10
    'Dim z As Long
    subtractcarry=0
    Do
         For n2=lenf-1 To diff Step -1
           takeaway= one[n2]-two[n2]+ten-subtractcarry
           three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n2
        If subtractcarry=0 Then Exit Do
        If n2=-1 Then Exit Do
        For n2=n2 To 0 Step -1
            takeaway= one[n2]-two[n2]+ten-subtractcarry
            three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            Next n2
        Exit Do
    Loop
   
    three=Ltrim(three,"0")
    If three="" Then Return "0"
    If swapflag=1 Then Swap NUM1,NUM2
   
    Return sign+three
   
End Function
'===============================================================================
'===============================================================================
function multiplier_7(byref num1 as string, byref num2 as string) as string
   
    dim as string number1,number2
    dim as string answer,outtext
   
    dim as string int1,frac1,int2,frac2
    dim as ulongint dec,dec1,len1,len2
    dim as string str1
    dim as string sign1,sign2,outsign
   
    number1 = num1
    number2 = num2
   
    sign1 = left(number1,1)
    if sign1 = "+" or sign1 = "-" then number1 = mid(number1,2) else sign1 = ""
   
    sign2 = left(number2,1)
    if sign2 = "+" or sign2 = "-" then number2 = mid(number2,2) else sign2 = ""
   
    if (sign1 = sign2) then outsign = ""
    if (sign1 <> sign2) then outsign = "-"
   
    dec = instr(1,number1,".")
    if dec > 0 then
        int1 = left(number1,dec-1)
        frac1 = mid(number1,dec+1)
    else
        int1 = number1
        frac1 = ""
    end if
   
    dec = instr(1,number2,".")
    if dec > 0 then
        int2 = left(number2,dec-1)
        frac2 = mid(number2,dec+1)
    else
        int2 = number2
        frac2 = ""
    end if

    dec = len(frac1)+len(frac2)
    number1 = int1+frac1
    number2 = int2+frac2

    'swap numbers so that bigger number is number1 and smaller is number2
    if len(number2) > len(number1) then swap number1,number2
    if len(number1) = len(number2) then
        if val(left(number2,1)) > val(left(number1,1)) then swap number1,number2
    end if

    'make numbers equal multiple of 7 bytes
    do
        str1 = str(len(number1)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number1 = "0" + number1
    loop until dec1 = 0
    do
        str1 = str(len(number2)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number2 = "0" + number2
    loop until dec1 = 0
   
    'convert the numeric strings to use pointers
    'convert number1
    dim as string n1 = string(len(number1)*8,chr(0))
    dim as ulongint ptr ulp1
    ulp1 = cptr(ulongint ptr,strptr(n1))
    dim as longint val1
    dim as longint len_1 = 0
    dim as uinteger a
    for a = 0 to len(number1)-1 step 7
        val1 = (number1[a+0]-48)*1000000ull
        val1+= (number1[a+1]-48)*100000ull
        val1+= (number1[a+2]-48)*10000ull
        val1+= (number1[a+3]-48)*1000ull
        val1+= (number1[a+4]-48)*100ull
        val1+= (number1[a+5]-48)*10ull
        val1+= (number1[a+6]-48)*1ull
        *ulp1 = val1
        ulp1+=1
        len_1+=8
    next
    number1 = left(n1,len_1)
    n1=""
   
    'convert the numeric strings to use pointers
    'convert number2
    dim as string n2 = string(len(number2)*8,chr(0))
    dim as ulongint ptr ulp2
    ulp2 = cptr(ulongint ptr,strptr(n2))
    dim as longint val2
    dim as longint len_2 = 0
    for a = 0 to len(number2)-1 step 7
        val2 = (number2[a+0]-48)*1000000ull
        val2+= (number2[a+1]-48)*100000ull
        val2+= (number2[a+2]-48)*10000ull
        val2+= (number2[a+3]-48)*1000ull
        val2+= (number2[a+4]-48)*100ull
        val2+= (number2[a+5]-48)*10ull
        val2+= (number2[a+6]-48)*1ull
        *ulp2 = val2
        ulp2+=1
        len_2+=8
    next
    number2 = left(n2,len_2)
    n2=""
   
    'create accumulator
    answer = string( len(number1) + len(number2) + 8 , chr(0) )
    'dimension vars for the mul
    dim as longint ptr start1,stop1,start2,stop2 'use longint because the pointers go negative
    dim as longint ptr chk_1 , chk_2
    dim as longint ptr inc1,inc2
    dim as longint ptr outplace
    dim as ulongint carry
    dim as ulongint total
    dim as ulongint blocknumber1 = len(number1)/8
    dim as ulongint blocknumber2 = len(number2)/8
    dim as ulongint outblocks = len(answer)/8
   
    'set initial accumulator place
    outplace = cptr(longint ptr , strptr(answer)) + (outblocks - 1)
    'set initial pointers into number1
    start1 = cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    stop1 =  cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    'set initial pointers into number2
    start2 = cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    stop2 =  cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    'set comparison to beg of numbers
    chk_1 = cptr( longint ptr , strptr(number1))
    chk_2 = cptr( longint ptr , strptr(number2))
   
    'zero the carry
    carry = 0
   
    'begin looping thru strings multiplying
    do
        'set total to zero
        total = 0
        'we are going to be incrementing thru number2 while decrementing thru number1
        'working in opposite directions from start1 to stop1 and start2 to stop2
        'inc1 works from right to left in the top number1 string
        'inc2 works from start2 to stop 2, in the bottom number2 string, decrementing each loop.
        inc1 = start1
        inc2 = start2
        do
            total += *inc1 * *inc2
            inc1-= 1
            inc2+= 1
        loop until inc2 = stop2+1
   
        total = total + carry
        carry = total \ 1e7
        *outplace = total mod 1e7
        '*outplace = imod(total , 1e7)
       
        outplace -= 1
       
        'each loop we need to decrement stop1
        'if stop1 goes negative we reset it to zero and decrement stop2
        stop1 -= 1
        if stop1 < chk_1 then
            stop1 += 1
            stop2 -=1
            if stop2 < chk_2 then stop2+= 1
        end if
        'each loop we decrement start2 to the left
        start2 -= 1
        'if start2 goes negative we reset it to zero and decrement start1
        'start1 is the rightmost digit of number1 we need to multiply
        if start2 < chk_2 then
            start2 += 1
            start1 -= 1
            if start1 < chk_1 then start1+=1
        end if
   
    loop until outplace = cptr(ulongint ptr,strptr(answer))+1
   
    'put in the carry at the end
    if carry > 0  then *outplace = carry else *outplace = 0
   
    'convert answer back to ascii
    for a as ulongint = 1 to outblocks-1 step 1
        val1 = *outplace
        outplace +=1
        outtext = outtext + right("0000000" + str(val1),7)
    next   

    'put in the decimal point
    outtext = left(outtext,len(outtext)-dec) + "." +  mid(outtext,(len(outtext)-dec)+1)
    'trim leading zeros
    outtext = trim(outtext,"0") 'if multiplying by 1, we have a zero in front.
    outtext = outsign + outtext

    return outtext

end function
'===============================================================================
'===============================================================================

albert
Posts: 5676
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Dec 04, 2018 0:21

I got it returning num2...

Here's 1,000 digits...

I still have to put in the r_avg stuff..

It takes about 3 seconds to return 1,000 digits.

Code: Select all


DECLARE FUNCTION multiplier_7(byref num1 as string, byref num2 as string) as string
Declare Function divide(n1 As String,n2 As String,decimal_places As integer,dpflag As String="s") As String

DECLARE Function minus(NUM1 As String,NUM2 As String) As String
Declare Function       plus( NUMber1 As String  ,  NUMber2 As String ) As String
Declare Function half(fl As String) As String


declare function convert_to_pointers( n as string ) as string
declare function make_equal( n as string) as string
declare function less_great ( n1 as string , n2 as string) as string

screen 19

dim as double time1 , time2
dim as longint size = 1000     ' works with 1 and 2 but not 3 (????)
do
   
    dim as string num1
    for a as longint =  1 to size step 1
        num1+=str(int(rnd*10))
    next
    if left(num1,1) = "0" then mid(num1,1,1) = str(int(rnd*9)+1)
   
    dim as string num2
    for a as longint =  1 to size step 1
        num2+=str(int(rnd*10))
    next
    if left(num2,1) = "0" then mid(num2,1,1) = str(int(rnd*9)+1)
   
    if num2 > num1 then swap num1 , num2
    if len(num2) > len(num1) then swap num1 , num2
    if len(num2) = len(num1) then if val(left(num2,1)) > val(left(num1,1)) then swap num1,num2
    '==========================================================
    'declare vars
    '==========================================================
    time1 = timer
   
    dim as string test = num2
   
    dim as string l_bot =  string( len(num2) , "0" )
    dim as string l_avg = string( len(num2) , "0" )
    dim as string l_top =  string( len(num2) , "9" )
     
    '==========================================================
    'make all var strings a multiple of 18 digits
    '==========================================================
    test = make_equal( test )
   
    l_bot  = make_equal( l_bot )
    l_avg = make_equal( l_avg )
    l_top  = make_equal( l_top )

    '==========================================================
    'convert the numeric strings to use pointers
    '==========================================================
    test = convert_to_pointers( test )
   
    l_bot = convert_to_pointers( l_bot )
    l_avg = convert_to_pointers( l_avg )
    l_top = convert_to_pointers( l_top )
   
    dim as string char
    dim as ulongint loops = 0
   
    do
       
        loops+=1
       
        l_avg = string( len(l_top) , chr(0) )
        dim as ubyte l_val = 0
        dim as ubyte l_frac = 0
        dim as ubyte ptr lt_ptr  = cptr( ubyte ptr , strptr( l_top ) )
        dim as ubyte ptr la_ptr = cptr( ubyte ptr , strptr( l_avg ) )
        dim as ubyte ptr lb_ptr = cptr( ubyte ptr , strptr( l_bot ) )
            for a as longint = 1 to len( l_avg) step 1
               
                if l_frac = 1 then *(la_ptr)+= 50
               
                l_val = ( *lt_ptr + *lb_ptr )
                *la_ptr+= ( l_val shr 1 )
               
                l_frac = l_val and 1
               
                if *(la_ptr) > 99 then *(la_ptr)-= 100 : *(la_ptr-1)+= 1
               
                if a >= 2 then
                dim as longint place = 1
                for b as longint = a to 2  step -1
                    if *(la_ptr-place) > 99 then *(la_ptr-place)-=100 : *(la_ptr-place-1)+=1
                    place+=1
                next
                 end if
           
                lt_ptr+=1
                la_ptr+=1
                lb_ptr+=1
            next
           
        char = less_great( l_avg , test )
       
        'print test , l_avg , char
        'print len(test) , len(l_avg)
       
        if inkey = " " then exit do
       
        if char = ">" then l_top = l_avg
        if char = "<" then l_bot = l_avg
        if char = "=" then exit do
     
     loop
     
    dim as ubyte ptr lavg_ptr = cptr( ubyte ptr , strptr(l_avg) )
    dim as string l_ans = ""
    for a as longint = 1 to len(l_avg) step 1
            l_ans+= right(string(2,"0") +  str( *lavg_ptr ) , 2 )
            lavg_ptr+=1
    next
    time2 = timer
   
    'dim as string my_answer = ""
    'dim as string real_answer = multiplier_7( num1 , num2 )
    'real_answer = left( real_answer , len(real_answer)-1 )
   
    dim as string difference = minus( l_ans , num2 )
   
    print
    'print "n1    = "  ; num1
    print "n2    = "  ; num2
    print "l_ans = " ; l_ans
    print
    'print "real ans = "  ; real_answer
    'print "my  ans  = " ; my_answer
    'print
    print "diff        =  " ; difference
    print
    print "loops = " ; loops  ,, time2-time1 
   
    if l_ans <> num2 then sleep
   
    if inkey = chr(27) then exit do
   
loop until inkey = chr(27)

sleep
end
'==================================================
'==================================================
function less_great ( n1 as string , n2 as string) as string
        dim as string char = "="
        if n1 = n2 then return char
        dim as ubyte ptr ubp1 = cptr( ubyte ptr , strptr(n1) )
        dim as ubyte ptr ubp2 = cptr( ubyte ptr , strptr(n2) )
        for a as longint = 1 to len(n1) step 1
            if *ubp1 > *ubp2 then char = ">" : exit for
            if *ubp1 < *ubp2 then char = "<" : exit for
            ubp1+=1
            ubp2+=1
        next
        return char
end function
'==================================================
'==================================================
function convert_to_pointers( n as string ) as string
   
    dim as string n1 = n
    dim as string n2
    dim as ubyte ptr ubp
    dim as ubyte val1
    dim as longint len_1
   
    n2 = string(len(n1) , chr(0))
    ubp = cptr(ubyte ptr,strptr(n2))
    len_1 = 0
    for a as longint = 0 to len(n1)-1 step 2
        val1  =  (n1[a+0]-48)*10
        val1+=  (n1[a+1]-48)*1
        *ubp = val1
        ubp+=1
        len_1+= 1
    next
    n2 = left(n2,len_1)
    return n2
end function
'==================================================
'==================================================
function make_equal( n as string) as string
    dim as string n1 = n
    dim as string str1
    dim as ulongint dec1
    do
        str1 = str( len(n1) / 2 )
        dec1 = instr(1,str1,".")
        if  dec1 <> 0 then n1 = "0" + n1
    loop until dec1 = 0
    return n1
end function
'==================================================
'==================================================
Function divide(n1 As String,n2 As String,decimal_places As integer,dpflag As String="s") As String
          Dim As String number=n1,divisor=n2
          dpflag=lcase(dpflag)
          'For MOD
          dim as integer modstop
          if dpflag="mod" then
              if len(n1)<len(n2) then return n1
              if len(n1)=len(n2) then
                  if n1<n2 then return n1
                  end if
              modstop=len(n1)-len(n2)+1
              end if
          if dpflag<>"mod" then
     If dpflag<>"s"  Then dpflag="raw"
     end if
        Dim runcount As integer
        '_______  LOOK UP TABLES ______________
        Dim Qmod(0 To 19) As Ubyte
        Dim bool(0 To 19) As Ubyte
        For z As Integer=0 To 19
    Qmod(z)=(z Mod 10+48)
    bool(z)=(-(10>z))
Next z
Dim answer As String   'THE ANSWER STRING 

'_______ SET THE DECIMAL WHERE IT SHOULD BE AT _______
Dim As String part1,part2
#macro set(decimal)
#macro insert(s,char,position)
If position > 0 And position <=Len(s) Then
part1=Mid$(s,1,position-1)
part2=Mid$(s,position)
s=part1+char+part2
End if
#endmacro
insert(answer,".",decpos)
  answer=thepoint+zeros+answer
If dpflag="raw" Then
    answer=Mid(answer,1,decimal_places)
    End if
#endmacro
'______________________________________________
'__________ SPLIT A STRING ABOUT A CHARACTRR __________
Dim As String var1,var2
    Dim pst As integer
      #macro split(stri,char,var1,var2)
    pst=Instr(stri,char)
    var1="":var2=""
    If pst<>0 Then
    var1=Rtrim(Mid(stri,1,pst),".")
    var2=Ltrim(Mid(stri,pst),".")
Else
    var1=stri
    End if
    #endmacro
   
       #macro Removepoint(s)
       split(s,".",var1,var2)
#endmacro
'__________ GET THE SIGN AND CLEAR THE -ve __________________
Dim sign As String
          If Left(number,1)="-" Xor Left (divisor,1)="-" Then sign="-"
            If Left(number,1)="-" Then  number=Ltrim(number,"-")
            If Left (divisor,1)="-" Then divisor=Ltrim(divisor,"-")
             
'DETERMINE THE DECIMAL POSITION BEFORE THE DIVISION
Dim As integer lennint,lenddec,lend,lenn,difflen
split(number,".",var1,var2)
lennint=Len(var1)
split(divisor,".",var1,var2)
lenddec=Len(var2)

If Instr(number,".") Then
    Removepoint(number)
    number=var1+var2
    End if
If Instr(divisor,".") Then
    Removepoint(divisor)
    divisor=var1+var2
    End if
Dim As integer numzeros
numzeros=Len(number)
number=Ltrim(number,"0"):divisor=Ltrim (divisor,"0")
numzeros=numzeros-Len(number)
lend=Len(divisor):lenn=Len(number)
If lend>lenn Then difflen=lend-lenn
Dim decpos As integer=lenddec+lennint-lend+2-numzeros 'THE POSITION INDICATOR
Dim _sgn As Byte=-Sgn(decpos)
If _sgn=0 Then _sgn=1
Dim As String thepoint=String(_sgn,".") 'DECIMAL AT START (IF)
Dim As String zeros=String(-decpos+1,"0")'ZEROS AT START (IF) e.g. .0009
if dpflag<>"mod" then
If Len(zeros) =0 Then dpflag="s"
end if
Dim As integer runlength
If Len(zeros) Then
     runlength=decimal_places
     answer=String(Len(zeros)+runlength+10,"0")
    If dpflag="raw" Then
        runlength=1
        answer=String(Len(zeros)+runlength+10,"0")
        If decimal_places>Len(zeros) Then
            runlength=runlength+(decimal_places-Len(zeros))
            answer=String(Len(zeros)+runlength+10,"0")
            End If
            End If

Else
decimal_places=decimal_places+decpos
runlength=decimal_places
answer=String(Len(zeros)+runlength+10,"0")
End if
'___________DECIMAL POSITION DETERMINED  _____________

'SET UP THE VARIABLES AND START UP CONDITIONS
number=number+String(difflen+decimal_places,"0")
        Dim count As integer
        Dim temp As String
        Dim copytemp As String
        Dim topstring As String
        Dim copytopstring As String
        Dim As integer lenf,lens
        Dim As Ubyte takeaway,subtractcarry
        Dim As integer n3,diff
       If Ltrim(divisor,"0")="" Then Return "Error :division by zero"   
        lens=Len(divisor)
         topstring=Left(number,lend)
         copytopstring=topstring
        Do
            count=0
        Do
            count=count+1
            copytemp=temp
   
            Do
'___________________ QUICK SUBTRACTION loop _________________             
           
lenf=Len(topstring)
If  lens<lenf=0 Then 'not
If Lens>lenf Then
temp= "done"
Exit Do
End if
If divisor>topstring Then
temp= "done"
Exit Do
End if
End if

  diff=lenf-lens
        temp=topstring
        subtractcarry=0
       
        For n3=lenf-1 To diff Step -1
            takeaway= topstring[n3]-divisor[n3-diff]+10-subtractcarry
            temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n3
        If subtractcarry=0 Then Exit Do
         If n3=-1 Then Exit Do
        For n3=n3 To 0 Step -1
            takeaway= topstring[n3]-38-subtractcarry
             temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            if subtractcarry=0 then exit do
            Next n3
        Exit Do
       
        Loop 'single run
        temp=Ltrim(temp,"0")
        If temp="" Then temp= "0"
            topstring=temp
        Loop Until temp="done"
     ' INDIVIDUAL CHARACTERS CARVED OFF ________________       
        runcount=runcount+1
       If count=1 Then
           topstring=copytopstring+Mid(number,lend+runcount,1)
           Else
       topstring=copytemp+Mid(number,lend+runcount,1)
   End If
       copytopstring=topstring
       topstring=Ltrim(topstring,"0")
       if dpflag="mod" then
       if runcount=modstop then
           if topstring="" then return "0"
           return mid(topstring,1,len(topstring)-1)
           end if
       end if
       answer[runcount-1]=count+47
       If topstring="" And runcount>Len(n1)+1 Then
           Exit Do
           End if
   Loop Until runcount=runlength+1
   
   ' END OF RUN TO REQUIRED DECIMAL PLACES
   set(decimal) 'PUT IN THE DECIMAL POINT
  'THERE IS ALWAYS A DECIMAL POINT SOMEWHERE IN THE ANSWER
  'NOW GET RID OF IT IF IT IS REDUNDANT
       answer=Rtrim(answer,"0")
       answer=Rtrim(answer,".")
       answer=Ltrim(answer,"0")
       If answer="" Then Return "0"
   Return sign+answer
End Function
'===============================================================================
'===============================================================================
Function half(fl As String) As String
    Dim As Ubyte main,carry,temp
    Dim As String sign   , s
    If Instr(fl,".")=0 Then s=fl+".0" Else s=fl+"0"
    If Instr(s,"-") Then sign="-":s=Ltrim(s,"-")
    Dim As String ans=s
    For z As Integer=0 To Len(s)-1
        If s[z]<>46 Then
            temp=(s[z]-48+carry)
            main=temp Shr 1
            carry=(temp And 1) Shl 3 +(temp And 1) Shl 1
            ans[z]=main+48
        End If
    Next z
    If Instr(ans,".") Then ans=Rtrim(ans,"0")
    ans=Rtrim(ans,".")
    ans=Ltrim(ans,"0")
    Return ans
End Function
'===============================================================================
'===============================================================================
'Dodicats plus & Minus functions
'===============================================================================
'===============================================================================
    Function plus(_num1 As String,_num2 As String) As String
        Dim  ADDQmod(0 To 19) As Ubyte
        Dim  ADDbool(0 To 19) As Ubyte
        For z As Integer=0 To 19
            ADDQmod(z)=(z Mod 10+48)
            ADDbool(z)=(-(10<=z))
        Next z
        Var _flag=0,n_=0
        Dim As Ubyte addup=Any,addcarry=Any
        #macro finish()
        answer=Ltrim(answer,"0")
        If _flag=1 Then Swap _num2,_num1
        Return answer
        #endmacro
        If Len(_num2)>Len(_num1) Then
            Swap _num2,_num1
            _flag=1
        End If
        Var diff=Len(_num1)-Len(_num2)
        Var answer="0"+_num1
        addcarry=0
        For n_=Len(_num1)-1 To diff Step -1
            addup=_num2[n_-diff]+_num1[n_]-96
            answer[n_+1]=ADDQmod(addup+addcarry)
            addcarry=ADDbool(addup+addcarry)
        Next n_
        If addcarry=0 Then
            finish()
        End If
        If n_=-1 Then
            answer[0]=addcarry+48
            finish()
            Endif
            For n_=n_ To 0 Step -1
                addup=_num1[n_]-48
                answer[n_+1]=ADDQmod(addup+addcarry)
                addcarry=ADDbool(addup+addcarry)
                If addcarry=0 Then Exit For
            Next n_
            answer[0]=addcarry+48
            finish()
        End Function
'===============================================================================
'===============================================================================
Function minus(NUM1 As String,NUM2 As String) As String
     'Dim As String copyfirstnum=mul_num_1,copysecondnum=mul_num_2
    Dim As Byte swapflag           
    Dim As Long lenf,lens
    Dim sign As String * 1
    'Dim As String part1,part2
    Dim bigger As Byte
     'set up tables
    Dim As Ubyte Qmod(0 To 19)
    Dim bool(0 To 19) As Ubyte

    For z As Integer=0 To 19
        Qmod(z)=cubyte(z Mod 10+48)
        bool(z)=cubyte(-(10>z))
    Next z
    lenf=Len(NUM1)
    lens=Len(NUM2)
    #macro compare(numbers)
        If Lens>lenf Then bigger= -1:Goto fin
        If Lens<lenf Then bigger =0:Goto fin
        If NUM2>NUM1 Then
            bigger=-1
        Else
            bigger= 0
        End If
        fin:
    #endmacro

    compare(numbers)
    If bigger Then
        sign="-"
        Swap NUM2,NUM1
        Swap lens,lenf
        swapflag=1
    Endif
    'lenf=Len(NUM1)
    'lens=Len(NUM2)
    Dim diff As Long=lenf-lens-Sgn(lenf-lens)
    Dim As String one,two,three
    three=NUM1
    two=String(lenf-lens,"0")+NUM2
    one=NUM1
    Dim As Long n2
    Dim As Ubyte takeaway,subtractcarry
    Dim As Ubyte ten=10
    'Dim z As Long
    subtractcarry=0
    Do
         For n2=lenf-1 To diff Step -1
           takeaway= one[n2]-two[n2]+ten-subtractcarry
           three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n2
        If subtractcarry=0 Then Exit Do
        If n2=-1 Then Exit Do
        For n2=n2 To 0 Step -1
            takeaway= one[n2]-two[n2]+ten-subtractcarry
            three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            Next n2
        Exit Do
    Loop
   
    three=Ltrim(three,"0")
    If three="" Then Return "0"
    If swapflag=1 Then Swap NUM1,NUM2
   
    Return sign+three
   
End Function
'===============================================================================
'===============================================================================
function multiplier_7(byref num1 as string, byref num2 as string) as string
   
    dim as string number1,number2
    dim as string answer,outtext
   
    dim as string int1,frac1,int2,frac2
    dim as ulongint dec,dec1,len1,len2
    dim as string str1
    dim as string sign1,sign2,outsign
   
    number1 = num1
    number2 = num2
   
    sign1 = left(number1,1)
    if sign1 = "+" or sign1 = "-" then number1 = mid(number1,2) else sign1 = ""
   
    sign2 = left(number2,1)
    if sign2 = "+" or sign2 = "-" then number2 = mid(number2,2) else sign2 = ""
   
    if (sign1 = sign2) then outsign = ""
    if (sign1 <> sign2) then outsign = "-"
   
    dec = instr(1,number1,".")
    if dec > 0 then
        int1 = left(number1,dec-1)
        frac1 = mid(number1,dec+1)
    else
        int1 = number1
        frac1 = ""
    end if
   
    dec = instr(1,number2,".")
    if dec > 0 then
        int2 = left(number2,dec-1)
        frac2 = mid(number2,dec+1)
    else
        int2 = number2
        frac2 = ""
    end if

    dec = len(frac1)+len(frac2)
    number1 = int1+frac1
    number2 = int2+frac2

    'swap numbers so that bigger number is number1 and smaller is number2
    if len(number2) > len(number1) then swap number1,number2
    if len(number1) = len(number2) then
        if val(left(number2,1)) > val(left(number1,1)) then swap number1,number2
    end if

    'make numbers equal multiple of 7 bytes
    do
        str1 = str(len(number1)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number1 = "0" + number1
    loop until dec1 = 0
    do
        str1 = str(len(number2)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number2 = "0" + number2
    loop until dec1 = 0
   
    'convert the numeric strings to use pointers
    'convert number1
    dim as string n1 = string(len(number1)*8,chr(0))
    dim as ulongint ptr ulp1
    ulp1 = cptr(ulongint ptr,strptr(n1))
    dim as longint val1
    dim as longint len_1 = 0
    dim as uinteger a
    for a = 0 to len(number1)-1 step 7
        val1 = (number1[a+0]-48)*1000000ull
        val1+= (number1[a+1]-48)*100000ull
        val1+= (number1[a+2]-48)*10000ull
        val1+= (number1[a+3]-48)*1000ull
        val1+= (number1[a+4]-48)*100ull
        val1+= (number1[a+5]-48)*10ull
        val1+= (number1[a+6]-48)*1ull
        *ulp1 = val1
        ulp1+=1
        len_1+=8
    next
    number1 = left(n1,len_1)
    n1=""
   
    'convert the numeric strings to use pointers
    'convert number2
    dim as string n2 = string(len(number2)*8,chr(0))
    dim as ulongint ptr ulp2
    ulp2 = cptr(ulongint ptr,strptr(n2))
    dim as longint val2
    dim as longint len_2 = 0
    for a = 0 to len(number2)-1 step 7
        val2 = (number2[a+0]-48)*1000000ull
        val2+= (number2[a+1]-48)*100000ull
        val2+= (number2[a+2]-48)*10000ull
        val2+= (number2[a+3]-48)*1000ull
        val2+= (number2[a+4]-48)*100ull
        val2+= (number2[a+5]-48)*10ull
        val2+= (number2[a+6]-48)*1ull
        *ulp2 = val2
        ulp2+=1
        len_2+=8
    next
    number2 = left(n2,len_2)
    n2=""
   
    'create accumulator
    answer = string( len(number1) + len(number2) + 8 , chr(0) )
    'dimension vars for the mul
    dim as longint ptr start1,stop1,start2,stop2 'use longint because the pointers go negative
    dim as longint ptr chk_1 , chk_2
    dim as longint ptr inc1,inc2
    dim as longint ptr outplace
    dim as ulongint carry
    dim as ulongint total
    dim as ulongint blocknumber1 = len(number1)/8
    dim as ulongint blocknumber2 = len(number2)/8
    dim as ulongint outblocks = len(answer)/8
   
    'set initial accumulator place
    outplace = cptr(longint ptr , strptr(answer)) + (outblocks - 1)
    'set initial pointers into number1
    start1 = cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    stop1 =  cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    'set initial pointers into number2
    start2 = cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    stop2 =  cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    'set comparison to beg of numbers
    chk_1 = cptr( longint ptr , strptr(number1))
    chk_2 = cptr( longint ptr , strptr(number2))
   
    'zero the carry
    carry = 0
   
    'begin looping thru strings multiplying
    do
        'set total to zero
        total = 0
        'we are going to be incrementing thru number2 while decrementing thru number1
        'working in opposite directions from start1 to stop1 and start2 to stop2
        'inc1 works from right to left in the top number1 string
        'inc2 works from start2 to stop 2, in the bottom number2 string, decrementing each loop.
        inc1 = start1
        inc2 = start2
        do
            total += *inc1 * *inc2
            inc1-= 1
            inc2+= 1
        loop until inc2 = stop2+1
   
        total = total + carry
        carry = total \ 1e7
        *outplace = total mod 1e7
        '*outplace = imod(total , 1e7)
       
        outplace -= 1
       
        'each loop we need to decrement stop1
        'if stop1 goes negative we reset it to zero and decrement stop2
        stop1 -= 1
        if stop1 < chk_1 then
            stop1 += 1
            stop2 -=1
            if stop2 < chk_2 then stop2+= 1
        end if
        'each loop we decrement start2 to the left
        start2 -= 1
        'if start2 goes negative we reset it to zero and decrement start1
        'start1 is the rightmost digit of number1 we need to multiply
        if start2 < chk_2 then
            start2 += 1
            start1 -= 1
            if start1 < chk_1 then start1+=1
        end if
   
    loop until outplace = cptr(ulongint ptr,strptr(answer))+1
   
    'put in the carry at the end
    if carry > 0  then *outplace = carry else *outplace = 0
   
    'convert answer back to ascii
    for a as ulongint = 1 to outblocks-1 step 1
        val1 = *outplace
        outplace +=1
        outtext = outtext + right("0000000" + str(val1),7)
    next   

    'put in the decimal point
    outtext = left(outtext,len(outtext)-dec) + "." +  mid(outtext,(len(outtext)-dec)+1)
    'trim leading zeros
    outtext = trim(outtext,"0") 'if multiplying by 1, we have a zero in front.
    outtext = outsign + outtext

    return outtext

end function
'===============================================================================
'===============================================================================

dodicat
Posts: 6491
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » Dec 05, 2018 15:41

Thanks Albert.
I think I'll tidy up all my big number stuff for general floats.
My string indexing method will not beat 1e9 or 1e7 jumps, but it should do for a kind of extended arithmetic.
albert
Posts: 5676
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Dec 07, 2018 2:20

@Dodicat

I got it returning some left digits of the mul...

Every time it prints "GREATER" the mul result is off

Code: Select all


DECLARE FUNCTION multiplier_7(byref num1 as string, byref num2 as string) as string
Declare Function divide(n1 As String,n2 As String,decimal_places As integer,dpflag As String="s") As String

DECLARE Function minus(NUM1 As String,NUM2 As String) As String
Declare Function       plus( NUMber1 As String  ,  NUMber2 As String ) As String
Declare Function half(fl As String) As String


declare function convert_to_pointers( n as string ) as string
declare function make_equal( n as string) as string
declare function less_great ( n1 as string , n2 as string) as string

screen 19

dim as double time1 , time2
dim as longint size = 10
do
   
    dim as string num1
    for a as longint =  1 to size step 1
        num1+=str(int(rnd*10))
    next
    if left(num1,1) = "0" then mid(num1,1,1) = str(int(rnd*9)+1)
   
    dim as string num2
    for a as longint =  1 to size step 1
        num2+=str(int(rnd*10))
    next
    if left(num2,1) = "0" then mid(num2,1,1) = str(int(rnd*9)+1)
   
    if num2 > num1 then swap num1 , num2
    if len(num2) > len(num1) then swap num1 , num2
    if len(num2) = len(num1) then if val(left(num2,1)) > val(left(num1,1)) then swap num1,num2
    '==========================================================
    'declare vars
    '==========================================================
    time1 = timer
   
    dim as string test = num2
   
    dim as string l_bot = left(num2,1) + string( len(num2) - 1 , "0" )
    dim as string l_avg = string( len(num2) , "0" )
    dim as string l_top =  plus( l_bot , l_bot )
    'if len(l_top) > len(l_bot) then l_top = string( len(num2) , "9" )
    if len(l_top) > len(l_bot) then
        l_top = "99" + string( len(num2)-2 , "0")
        l_bot = "0" + l_bot
        l_avg = l_bot
        print
        print "GREATER"
        print
    end  if
     
    dim as string r_bot  = multiplier_7( num1 , left(num2,1) )
        r_bot = left( r_bot , instr(1 , r_bot , "." ) - 1 )
        r_bot+= string( len(num1) + len(num2) , "0" )
        r_bot  = left( r_bot , len(num1)+len(num2) )
    dim as string r_avg = string( len(r_bot) , "0" )
    dim as string r_top  = plus( r_bot , r_bot )
    if len(r_top) > len(r_bot) then r_bot = "0" + r_bot : r_avg = r_bot
   
    '==========================================================
    'make all var strings a multiple of 18 digits
    '==========================================================
    test = make_equal( test )
   
    l_bot  = make_equal( l_bot )
    l_avg = make_equal( l_avg )
    l_top  = make_equal( l_top )

    r_bot   = make_equal( r_bot )
    r_avg  = make_equal( r_avg )
    r_top   = make_equal( r_top )
   
    '==========================================================
    'convert the numeric strings to use pointers
    '==========================================================
    test = convert_to_pointers( test )
   
    l_bot = convert_to_pointers( l_bot )
    l_avg = convert_to_pointers( l_avg )
    l_top = convert_to_pointers( l_top )
   
    r_bot = convert_to_pointers( r_bot )
    r_avg = convert_to_pointers( r_avg )
    r_top = convert_to_pointers( r_top )
   
    '==========================================================
    '==========================================================
   
    dim as string char
    dim as ulongint loops = 0
   
    do
       
        loops+=1

        dim as string l_check = l_avg
        l_avg = string( len(l_top) , chr(0) )
        dim as ubyte l_val = 0
        dim as ubyte l_frac = 0
        dim as ubyte ptr lt_ptr  = cptr( ubyte ptr , strptr( l_top ) )
        dim as ubyte ptr la_ptr = cptr( ubyte ptr , strptr( l_avg ) )
        dim as ubyte ptr lb_ptr = cptr( ubyte ptr , strptr( l_bot ) )
            for a as longint = 1 to len( l_avg)  step 1
                if l_frac = 1 then *(la_ptr)+= 50
                l_val = ( *lt_ptr + *lb_ptr )
                *la_ptr+= ( l_val shr 1 )
                l_frac = l_val and 1
                if *la_ptr > 99 then *la_ptr-= 100 : *(la_ptr-1)+= 1
                if a = len(l_avg) then
                dim as longint place = 0
                for b as longint = a to 2  step -1
                    if *(la_ptr-place) > 99 then *(la_ptr-place)-=100 : *(la_ptr-place-1)+=1
                    place+=1
                next
                end if
                lt_ptr+=1
                la_ptr+=1
                lb_ptr+=1
            next
           
        dim as string r_check = r_avg
        r_avg = string( len(r_top) , chr(0) )
        dim as ubyte r_val = 0
        dim as ubyte r_frac = 0
        dim as ubyte ptr rt_ptr  = cptr( ubyte ptr , strptr(r_top ) )
        dim as ubyte ptr ra_ptr = cptr( ubyte ptr , strptr( r_avg ) )
        dim as ubyte ptr rb_ptr = cptr( ubyte ptr , strptr( r_bot ) )
            for a as longint = 1 to len( r_avg) step 1
                if r_frac = 1 then *(ra_ptr)+= 50
                r_val = ( *rt_ptr + *rb_ptr )
                *ra_ptr+= ( r_val shr 1 )
                r_frac = r_val and 1
                if *ra_ptr > 99 then *ra_ptr-= 100 : *(ra_ptr-1)+=1
                if a = len(r_avg) then
                dim as longint place = 0
                for b as longint = a to 2  step -1
                    if *(ra_ptr-place) > 99 then *(ra_ptr-place)-=100 : *(ra_ptr-place-1)+=1
                    place+=1
                next
                end if
                rt_ptr+=1
                ra_ptr+=1
                rb_ptr+=1
            next
           
        char = less_great( l_avg , test )
       
        if inkey = " " then exit do
       
        if char = ">" then l_top = l_avg : r_top = r_avg
        if char = "<" then l_bot = l_avg : r_bot = r_avg
        if char = "=" then exit do
        'if l_avg = l_check or r_avg = r_check then exit do
       
     loop
     
    dim as ubyte ptr lavg_ptr = cptr( ubyte ptr , strptr(l_avg) )
    dim as string l_ans = ""
    for a as longint = 1 to len(l_avg) step 1
            l_ans+= right(string(2,"0") +  str( *lavg_ptr ) , 2 )
            lavg_ptr+=1
    next
    l_ans = ltrim( l_ans,"0")
    dim as ubyte ptr ravg_ptr = cptr( ubyte ptr , strptr(r_avg) )
    dim as string r_ans = ""
    for a as longint = 1 to len(r_avg) step 1
            r_ans+= right(string(2,"0") +  str( *ravg_ptr ) , 2 )
            ravg_ptr+=1
    next
    r_ans = ltrim( r_ans,"0")
   
    time2 = timer
   
    dim as string my_answer = ""
    dim as string real_answer = multiplier_7( num1 , num2 )
    real_answer = left( real_answer , len(real_answer)-1 )
   
    dim as string difference1 = minus( l_ans , num2 )
    dim as string difference2 = minus( r_ans , real_answer )
   
    print
    print "n1    = "  ; num1
    print "n2    = "  ; num2
    print "l_ans = " ; l_ans
    print
    print "real ans = "  ; real_answer
    print "my  ans  = " ; r_ans
    print
    print "diff        =  " ; difference1 , difference2
    print
    print "loops = " ; loops  ,, time2-time1 
   
    if l_ans <> num2 then sleep
    if r_ans <> real_answer then sleep
   
    if inkey = chr(27) then exit do
    if inkey = " " then sleep
   
loop until inkey = chr(27)

sleep
end
'==================================================
'==================================================
function less_great ( n1 as string , n2 as string) as string
        dim as string char = "="
        if n1 = n2 then return char
        dim as ubyte ptr ubp1 = cptr( ubyte ptr , strptr(n1) )
        dim as ubyte ptr ubp2 = cptr( ubyte ptr , strptr(n2) )
        for a as longint = 1 to len(n1) step 1
            if *ubp1 > *ubp2 then char = ">" : exit for
            if *ubp1 < *ubp2 then char = "<" : exit for
            ubp1+=1
            ubp2+=1
        next
        return char
end function
'==================================================
'==================================================
function convert_to_pointers( n as string ) as string
   
    dim as string n1 = n
    dim as string n2
    dim as ubyte ptr ubp
    dim as ubyte val1
    dim as longint len_1
   
    n2 = string(len(n1) , chr(0))
    ubp = cptr(ubyte ptr,strptr(n2))
    len_1 = 0
    for a as longint = 0 to len(n1)-1 step 2
        val1  =  (n1[a+0]-48)*10
        val1+=  (n1[a+1]-48)*1
        *ubp = val1
        ubp+=1
        len_1+= 1
    next
    n2 = left(n2,len_1)
    return n2
end function
'==================================================
'==================================================
function make_equal( n as string) as string
    dim as string n1 = n
    dim as string str1
    dim as ulongint dec1
    do
        str1 = str( len(n1) / 2 )
        dec1 = instr(1,str1,".")
        if  dec1 <> 0 then n1 = "0" + n1
    loop until dec1 = 0
    return n1
end function
'==================================================
'==================================================
Function divide(n1 As String,n2 As String,decimal_places As integer,dpflag As String="s") As String
          Dim As String number=n1,divisor=n2
          dpflag=lcase(dpflag)
          'For MOD
          dim as integer modstop
          if dpflag="mod" then
              if len(n1)<len(n2) then return n1
              if len(n1)=len(n2) then
                  if n1<n2 then return n1
                  end if
              modstop=len(n1)-len(n2)+1
              end if
          if dpflag<>"mod" then
     If dpflag<>"s"  Then dpflag="raw"
     end if
        Dim runcount As integer
        '_______  LOOK UP TABLES ______________
        Dim Qmod(0 To 19) As Ubyte
        Dim bool(0 To 19) As Ubyte
        For z As Integer=0 To 19
    Qmod(z)=(z Mod 10+48)
    bool(z)=(-(10>z))
Next z
Dim answer As String   'THE ANSWER STRING 

'_______ SET THE DECIMAL WHERE IT SHOULD BE AT _______
Dim As String part1,part2
#macro set(decimal)
#macro insert(s,char,position)
If position > 0 And position <=Len(s) Then
part1=Mid$(s,1,position-1)
part2=Mid$(s,position)
s=part1+char+part2
End if
#endmacro
insert(answer,".",decpos)
  answer=thepoint+zeros+answer
If dpflag="raw" Then
    answer=Mid(answer,1,decimal_places)
    End if
#endmacro
'______________________________________________
'__________ SPLIT A STRING ABOUT A CHARACTRR __________
Dim As String var1,var2
    Dim pst As integer
      #macro split(stri,char,var1,var2)
    pst=Instr(stri,char)
    var1="":var2=""
    If pst<>0 Then
    var1=Rtrim(Mid(stri,1,pst),".")
    var2=Ltrim(Mid(stri,pst),".")
Else
    var1=stri
    End if
    #endmacro
   
       #macro Removepoint(s)
       split(s,".",var1,var2)
#endmacro
'__________ GET THE SIGN AND CLEAR THE -ve __________________
Dim sign As String
          If Left(number,1)="-" Xor Left (divisor,1)="-" Then sign="-"
            If Left(number,1)="-" Then  number=Ltrim(number,"-")
            If Left (divisor,1)="-" Then divisor=Ltrim(divisor,"-")
             
'DETERMINE THE DECIMAL POSITION BEFORE THE DIVISION
Dim As integer lennint,lenddec,lend,lenn,difflen
split(number,".",var1,var2)
lennint=Len(var1)
split(divisor,".",var1,var2)
lenddec=Len(var2)

If Instr(number,".") Then
    Removepoint(number)
    number=var1+var2
    End if
If Instr(divisor,".") Then
    Removepoint(divisor)
    divisor=var1+var2
    End if
Dim As integer numzeros
numzeros=Len(number)
number=Ltrim(number,"0"):divisor=Ltrim (divisor,"0")
numzeros=numzeros-Len(number)
lend=Len(divisor):lenn=Len(number)
If lend>lenn Then difflen=lend-lenn
Dim decpos As integer=lenddec+lennint-lend+2-numzeros 'THE POSITION INDICATOR
Dim _sgn As Byte=-Sgn(decpos)
If _sgn=0 Then _sgn=1
Dim As String thepoint=String(_sgn,".") 'DECIMAL AT START (IF)
Dim As String zeros=String(-decpos+1,"0")'ZEROS AT START (IF) e.g. .0009
if dpflag<>"mod" then
If Len(zeros) =0 Then dpflag="s"
end if
Dim As integer runlength
If Len(zeros) Then
     runlength=decimal_places
     answer=String(Len(zeros)+runlength+10,"0")
    If dpflag="raw" Then
        runlength=1
        answer=String(Len(zeros)+runlength+10,"0")
        If decimal_places>Len(zeros) Then
            runlength=runlength+(decimal_places-Len(zeros))
            answer=String(Len(zeros)+runlength+10,"0")
            End If
            End If

Else
decimal_places=decimal_places+decpos
runlength=decimal_places
answer=String(Len(zeros)+runlength+10,"0")
End if
'___________DECIMAL POSITION DETERMINED  _____________

'SET UP THE VARIABLES AND START UP CONDITIONS
number=number+String(difflen+decimal_places,"0")
        Dim count As integer
        Dim temp As String
        Dim copytemp As String
        Dim topstring As String
        Dim copytopstring As String
        Dim As integer lenf,lens
        Dim As Ubyte takeaway,subtractcarry
        Dim As integer n3,diff
       If Ltrim(divisor,"0")="" Then Return "Error :division by zero"   
        lens=Len(divisor)
         topstring=Left(number,lend)
         copytopstring=topstring
        Do
            count=0
        Do
            count=count+1
            copytemp=temp
   
            Do
'___________________ QUICK SUBTRACTION loop _________________             
           
lenf=Len(topstring)
If  lens<lenf=0 Then 'not
If Lens>lenf Then
temp= "done"
Exit Do
End if
If divisor>topstring Then
temp= "done"
Exit Do
End if
End if

  diff=lenf-lens
        temp=topstring
        subtractcarry=0
       
        For n3=lenf-1 To diff Step -1
            takeaway= topstring[n3]-divisor[n3-diff]+10-subtractcarry
            temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n3
        If subtractcarry=0 Then Exit Do
         If n3=-1 Then Exit Do
        For n3=n3 To 0 Step -1
            takeaway= topstring[n3]-38-subtractcarry
             temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            if subtractcarry=0 then exit do
            Next n3
        Exit Do
       
        Loop 'single run
        temp=Ltrim(temp,"0")
        If temp="" Then temp= "0"
            topstring=temp
        Loop Until temp="done"
     ' INDIVIDUAL CHARACTERS CARVED OFF ________________       
        runcount=runcount+1
       If count=1 Then
           topstring=copytopstring+Mid(number,lend+runcount,1)
           Else
       topstring=copytemp+Mid(number,lend+runcount,1)
   End If
       copytopstring=topstring
       topstring=Ltrim(topstring,"0")
       if dpflag="mod" then
       if runcount=modstop then
           if topstring="" then return "0"
           return mid(topstring,1,len(topstring)-1)
           end if
       end if
       answer[runcount-1]=count+47
       If topstring="" And runcount>Len(n1)+1 Then
           Exit Do
           End if
   Loop Until runcount=runlength+1
   
   ' END OF RUN TO REQUIRED DECIMAL PLACES
   set(decimal) 'PUT IN THE DECIMAL POINT
  'THERE IS ALWAYS A DECIMAL POINT SOMEWHERE IN THE ANSWER
  'NOW GET RID OF IT IF IT IS REDUNDANT
       answer=Rtrim(answer,"0")
       answer=Rtrim(answer,".")
       answer=Ltrim(answer,"0")
       If answer="" Then Return "0"
   Return sign+answer
End Function
'===============================================================================
'===============================================================================
Function half(fl As String) As String
    Dim As Ubyte main,carry,temp
    Dim As String sign   , s
    If Instr(fl,".")=0 Then s=fl+".0" Else s=fl+"0"
    If Instr(s,"-") Then sign="-":s=Ltrim(s,"-")
    Dim As String ans=s
    For z As Integer=0 To Len(s)-1
        If s[z]<>46 Then
            temp=(s[z]-48+carry)
            main=temp Shr 1
            carry=(temp And 1) Shl 3 +(temp And 1) Shl 1
            ans[z]=main+48
        End If
    Next z
    If Instr(ans,".") Then ans=Rtrim(ans,"0")
    ans=Rtrim(ans,".")
    ans=Ltrim(ans,"0")
    Return ans
End Function
'===============================================================================
'===============================================================================
'Dodicats plus & Minus functions
'===============================================================================
'===============================================================================
    Function plus(_num1 As String,_num2 As String) As String
        Dim  ADDQmod(0 To 19) As Ubyte
        Dim  ADDbool(0 To 19) As Ubyte
        For z As Integer=0 To 19
            ADDQmod(z)=(z Mod 10+48)
            ADDbool(z)=(-(10<=z))
        Next z
        Var _flag=0,n_=0
        Dim As Ubyte addup=Any,addcarry=Any
        #macro finish()
        answer=Ltrim(answer,"0")
        If _flag=1 Then Swap _num2,_num1
        Return answer
        #endmacro
        If Len(_num2)>Len(_num1) Then
            Swap _num2,_num1
            _flag=1
        End If
        Var diff=Len(_num1)-Len(_num2)
        Var answer="0"+_num1
        addcarry=0
        For n_=Len(_num1)-1 To diff Step -1
            addup=_num2[n_-diff]+_num1[n_]-96
            answer[n_+1]=ADDQmod(addup+addcarry)
            addcarry=ADDbool(addup+addcarry)
        Next n_
        If addcarry=0 Then
            finish()
        End If
        If n_=-1 Then
            answer[0]=addcarry+48
            finish()
            Endif
            For n_=n_ To 0 Step -1
                addup=_num1[n_]-48
                answer[n_+1]=ADDQmod(addup+addcarry)
                addcarry=ADDbool(addup+addcarry)
                If addcarry=0 Then Exit For
            Next n_
            answer[0]=addcarry+48
            finish()
        End Function
'===============================================================================
'===============================================================================
Function minus(NUM1 As String,NUM2 As String) As String
     'Dim As String copyfirstnum=mul_num_1,copysecondnum=mul_num_2
    Dim As Byte swapflag           
    Dim As Long lenf,lens
    Dim sign As String * 1
    'Dim As String part1,part2
    Dim bigger As Byte
     'set up tables
    Dim As Ubyte Qmod(0 To 19)
    Dim bool(0 To 19) As Ubyte

    For z As Integer=0 To 19
        Qmod(z)=cubyte(z Mod 10+48)
        bool(z)=cubyte(-(10>z))
    Next z
    lenf=Len(NUM1)
    lens=Len(NUM2)
    #macro compare(numbers)
        If Lens>lenf Then bigger= -1:Goto fin
        If Lens<lenf Then bigger =0:Goto fin
        If NUM2>NUM1 Then
            bigger=-1
        Else
            bigger= 0
        End If
        fin:
    #endmacro

    compare(numbers)
    If bigger Then
        sign="-"
        Swap NUM2,NUM1
        Swap lens,lenf
        swapflag=1
    Endif
    'lenf=Len(NUM1)
    'lens=Len(NUM2)
    Dim diff As Long=lenf-lens-Sgn(lenf-lens)
    Dim As String one,two,three
    three=NUM1
    two=String(lenf-lens,"0")+NUM2
    one=NUM1
    Dim As Long n2
    Dim As Ubyte takeaway,subtractcarry
    Dim As Ubyte ten=10
    'Dim z As Long
    subtractcarry=0
    Do
         For n2=lenf-1 To diff Step -1
           takeaway= one[n2]-two[n2]+ten-subtractcarry
           three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n2
        If subtractcarry=0 Then Exit Do
        If n2=-1 Then Exit Do
        For n2=n2 To 0 Step -1
            takeaway= one[n2]-two[n2]+ten-subtractcarry
            three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            Next n2
        Exit Do
    Loop
   
    three=Ltrim(three,"0")
    If three="" Then Return "0"
    If swapflag=1 Then Swap NUM1,NUM2
   
    Return sign+three
   
End Function
'===============================================================================
'===============================================================================
function multiplier_7(byref num1 as string, byref num2 as string) as string
   
    dim as string number1,number2
    dim as string answer,outtext
   
    dim as string int1,frac1,int2,frac2
    dim as ulongint dec,dec1,len1,len2
    dim as string str1
    dim as string sign1,sign2,outsign
   
    number1 = num1
    number2 = num2
   
    sign1 = left(number1,1)
    if sign1 = "+" or sign1 = "-" then number1 = mid(number1,2) else sign1 = ""
   
    sign2 = left(number2,1)
    if sign2 = "+" or sign2 = "-" then number2 = mid(number2,2) else sign2 = ""
   
    if (sign1 = sign2) then outsign = ""
    if (sign1 <> sign2) then outsign = "-"
   
    dec = instr(1,number1,".")
    if dec > 0 then
        int1 = left(number1,dec-1)
        frac1 = mid(number1,dec+1)
    else
        int1 = number1
        frac1 = ""
    end if
   
    dec = instr(1,number2,".")
    if dec > 0 then
        int2 = left(number2,dec-1)
        frac2 = mid(number2,dec+1)
    else
        int2 = number2
        frac2 = ""
    end if

    dec = len(frac1)+len(frac2)
    number1 = int1+frac1
    number2 = int2+frac2

    'swap numbers so that bigger number is number1 and smaller is number2
    if len(number2) > len(number1) then swap number1,number2
    if len(number1) = len(number2) then
        if val(left(number2,1)) > val(left(number1,1)) then swap number1,number2
    end if

    'make numbers equal multiple of 7 bytes
    do
        str1 = str(len(number1)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number1 = "0" + number1
    loop until dec1 = 0
    do
        str1 = str(len(number2)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number2 = "0" + number2
    loop until dec1 = 0
   
    'convert the numeric strings to use pointers
    'convert number1
    dim as string n1 = string(len(number1)*8,chr(0))
    dim as ulongint ptr ulp1
    ulp1 = cptr(ulongint ptr,strptr(n1))
    dim as longint val1
    dim as longint len_1 = 0
    dim as uinteger a
    for a = 0 to len(number1)-1 step 7
        val1 = (number1[a+0]-48)*1000000ull
        val1+= (number1[a+1]-48)*100000ull
        val1+= (number1[a+2]-48)*10000ull
        val1+= (number1[a+3]-48)*1000ull
        val1+= (number1[a+4]-48)*100ull
        val1+= (number1[a+5]-48)*10ull
        val1+= (number1[a+6]-48)*1ull
        *ulp1 = val1
        ulp1+=1
        len_1+=8
    next
    number1 = left(n1,len_1)
    n1=""
   
    'convert the numeric strings to use pointers
    'convert number2
    dim as string n2 = string(len(number2)*8,chr(0))
    dim as ulongint ptr ulp2
    ulp2 = cptr(ulongint ptr,strptr(n2))
    dim as longint val2
    dim as longint len_2 = 0
    for a = 0 to len(number2)-1 step 7
        val2 = (number2[a+0]-48)*1000000ull
        val2+= (number2[a+1]-48)*100000ull
        val2+= (number2[a+2]-48)*10000ull
        val2+= (number2[a+3]-48)*1000ull
        val2+= (number2[a+4]-48)*100ull
        val2+= (number2[a+5]-48)*10ull
        val2+= (number2[a+6]-48)*1ull
        *ulp2 = val2
        ulp2+=1
        len_2+=8
    next
    number2 = left(n2,len_2)
    n2=""
   
    'create accumulator
    answer = string( len(number1) + len(number2) + 8 , chr(0) )
    'dimension vars for the mul
    dim as longint ptr start1,stop1,start2,stop2 'use longint because the pointers go negative
    dim as longint ptr chk_1 , chk_2
    dim as longint ptr inc1,inc2
    dim as longint ptr outplace
    dim as ulongint carry
    dim as ulongint total
    dim as ulongint blocknumber1 = len(number1)/8
    dim as ulongint blocknumber2 = len(number2)/8
    dim as ulongint outblocks = len(answer)/8
   
    'set initial accumulator place
    outplace = cptr(longint ptr , strptr(answer)) + (outblocks - 1)
    'set initial pointers into number1
    start1 = cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    stop1 =  cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    'set initial pointers into number2
    start2 = cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    stop2 =  cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    'set comparison to beg of numbers
    chk_1 = cptr( longint ptr , strptr(number1))
    chk_2 = cptr( longint ptr , strptr(number2))
   
    'zero the carry
    carry = 0
   
    'begin looping thru strings multiplying
    do
        'set total to zero
        total = 0
        'we are going to be incrementing thru number2 while decrementing thru number1
        'working in opposite directions from start1 to stop1 and start2 to stop2
        'inc1 works from right to left in the top number1 string
        'inc2 works from start2 to stop 2, in the bottom number2 string, decrementing each loop.
        inc1 = start1
        inc2 = start2
        do
            total += *inc1 * *inc2
            inc1-= 1
            inc2+= 1
        loop until inc2 = stop2+1
   
        total = total + carry
        carry = total \ 1e7
        *outplace = total mod 1e7
        '*outplace = imod(total , 1e7)
       
        outplace -= 1
       
        'each loop we need to decrement stop1
        'if stop1 goes negative we reset it to zero and decrement stop2
        stop1 -= 1
        if stop1 < chk_1 then
            stop1 += 1
            stop2 -=1
            if stop2 < chk_2 then stop2+= 1
        end if
        'each loop we decrement start2 to the left
        start2 -= 1
        'if start2 goes negative we reset it to zero and decrement start1
        'start1 is the rightmost digit of number1 we need to multiply
        if start2 < chk_2 then
            start2 += 1
            start1 -= 1
            if start1 < chk_1 then start1+=1
        end if
   
    loop until outplace = cptr(ulongint ptr,strptr(answer))+1
   
    'put in the carry at the end
    if carry > 0  then *outplace = carry else *outplace = 0
   
    'convert answer back to ascii
    for a as ulongint = 1 to outblocks-1 step 1
        val1 = *outplace
        outplace +=1
        outtext = outtext + right("0000000" + str(val1),7)
    next   

    'put in the decimal point
    outtext = left(outtext,len(outtext)-dec) + "." +  mid(outtext,(len(outtext)-dec)+1)
    'trim leading zeros
    outtext = trim(outtext,"0") 'if multiplying by 1, we have a zero in front.
    outtext = outsign + outtext

    return outtext

end function
'===============================================================================
'===============================================================================

albert
Posts: 5676
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Dec 08, 2018 2:23

@Richard
@Dodicat

I got it returning some correct answers...still need to troubleshoot it some...

I still got to figure out why , some numbers are greater than the mul result..

Code: Select all


DECLARE FUNCTION multiplier_7(byref num1 as string, byref num2 as string) as string
Declare Function divide(n1 As String,n2 As String,decimal_places As integer,dpflag As String="s") As String

DECLARE Function minus(NUM1 As String,NUM2 As String) As String
Declare Function       plus( NUMber1 As String  ,  NUMber2 As String ) As String
Declare Function half(fl As String) As String


declare function convert_to_pointers( n as string ) as string
declare function make_equal( n as string) as string
declare function less_great ( n1 as string , n2 as string) as string

screen 19

dim as double time1 , time2

dim as longint size = 10

dim as longint total = 0
dim as longint r_correct = 0

do
   
    total+=1
   
    dim as string num1
    for a as longint =  1 to size step 1
        num1+=str(int(rnd*10))
    next
    if left(num1,1) = "0" then mid(num1,1,1) = str(int(rnd*9)+1)
   
    dim as string num2
    for a as longint =  1 to size step 1
        num2+=str(int(rnd*10))
    next
    if left(num2,1) = "0" then mid(num2,1,1) = str(int(rnd*9)+1)
   
    if len(num2) = len(num1) then if num2 > num1 then swap num1 , num2
    if len(num2) > len(num1) then swap num1 , num2
    if len(num2) = len(num1) then if val(left(num2,1)) > val(left(num1,1)) then swap num1,num2
   
    '==========================================================
    'declare vars
    '==========================================================
    time1 = timer
   
    dim as string test = num2
   
    dim as string l_bot = left(num2,1) + string( len(num2) - 1 , "0" )
    dim as string l_avg
    dim as string l_top =  plus( l_bot , l_bot )
   
    dim as string r_bot  = multiplier_7( num1 , left(num2,1) )
        r_bot = left( r_bot , len(r_bot) - 1 )
        r_bot+= string( len(num1) + len(num2) , "0" )
        r_bot  = left( r_bot , len(num1)+len(num2) )
    dim as string r_avg
    dim as string r_top  = plus( r_bot , r_bot )
   
    dim as string point_5 = half( num1 )
        if right(point_5 , 2 ) = ".5" then point_5 = left( point_5 , instr( 1 , point_5 , "." ) - 1 )
   
    '==========================================================
    'make all var strings a multiple of 18 digits
    '==========================================================
    test = make_equal( test )
   
    l_bot  = make_equal( l_bot )
    l_avg = make_equal( l_avg )
    l_top  = make_equal( l_top )

    r_bot   = make_equal( r_bot )
    r_avg  = make_equal( r_avg )
    r_top   = make_equal( r_top )
   
    '==========================================================
    'convert the numeric strings to use pointers
    '==========================================================
    test = convert_to_pointers( test )
   
    l_bot = convert_to_pointers( l_bot )
    l_avg = convert_to_pointers( l_avg )
    l_top = convert_to_pointers( l_top )
   
    r_bot = convert_to_pointers( r_bot )
    r_avg = convert_to_pointers( r_avg )
    r_top = convert_to_pointers( r_top )
   
    if len(l_top) > len(l_bot)  then
        l_bot = chr(0) + l_bot
        test = chr(0) + test
    end if
    if len(r_top) > len(r_bot)  then
        r_bot = chr(0) + r_bot
    end if
   
    point_5 = convert_to_pointers( point_5 )
   
    '==========================================================
    '==========================================================
   
    dim as string char
    dim as ulongint loops = 0
    do
       
        loops+=1
       
        dim as string l_check = l_avg
        l_avg = string( len(l_top) , chr(0) )
        dim as ubyte l_val = 0
        dim as ubyte l_frac = 0
        dim as ubyte ptr lt_ptr  = cptr( ubyte ptr , strptr( l_top ) )
        dim as ubyte ptr la_ptr = cptr( ubyte ptr , strptr( l_avg ) )
        dim as ubyte ptr lb_ptr = cptr( ubyte ptr , strptr( l_bot ) )
            for a as longint = 1 to len( l_avg)  step 1
                if l_frac = 1 then *(la_ptr)+= 50
                l_val = ( *lt_ptr + *lb_ptr )
                *la_ptr+= ( l_val shr 1 )
                l_frac = l_val  and 1
                if *la_ptr > 99 then *la_ptr-= 100 : *(la_ptr-1)+= 1
                lt_ptr+=1
                la_ptr+=1
                lb_ptr+=1
            next
            if l_frac = 1 then  *(la_ptr-1)+= 1
            dim as longint place = 1
            for a as longint = len(l_avg) to 2  step -1
                if *(la_ptr-place) > 99 then *(la_ptr-place)-=100 : *(la_ptr-place-1)+=1
                place+=1
            next
       
           
        dim as string r_check = r_avg
        r_avg = string( len(r_top) , chr(0) )
        dim as ubyte r_val = 0
        dim as ubyte r_frac = 0
        dim as ubyte ptr rt_ptr  = cptr( ubyte ptr , strptr(r_top ) )
        dim as ubyte ptr ra_ptr = cptr( ubyte ptr , strptr( r_avg ) )
        dim as ubyte ptr rb_ptr = cptr( ubyte ptr , strptr( r_bot ) )
            for a as longint = 1 to len( r_avg) step 1
                if r_frac = 1 then *(ra_ptr)+= 50
                r_val = ( *rt_ptr + *rb_ptr )
                *ra_ptr+= ( r_val shr 1 )
                r_frac = r_val and 1
                if *ra_ptr > 99 then *ra_ptr-= 100 : *(ra_ptr-1)+=1
                rt_ptr+=1
                ra_ptr+=1
                rb_ptr+=1
            next
            place = 1
            for a as longint = len(r_avg) to 2  step -1
                if *(ra_ptr-place) > 99 then *(ra_ptr-place)-=100 : *(ra_ptr-place-1)+=1
                place+=1
            next
           
           if l_frac = 1 then
                if r_frac = 1 then *(ra_ptr-1)+=1
                dim as ubyte ptr ubp = cptr( ubyte ptr , strptr( point_5 ) ) + len(point_5) - 1
                dim as longint place = 1
                for a as longint = len(point_5) to 1 step -1
                    *(ra_ptr-place)+=*ubp
                    ubp-=1
                    place+=1
                next
                place = 1
                for a as longint = len(r_avg) to 2  step -1
                    if *(ra_ptr-place) > 99 then *(ra_ptr-place)-=100 : *(ra_ptr-place-1)+=1
                    place+=1
                next
           end if
           
        char = less_great( l_avg , test )
       
        if inkey = " " then exit do
       
        if char = ">" then l_top = l_avg : r_top = r_avg
        if char = "<" then l_bot = l_avg : r_bot = r_avg
        if char = "=" then exit do
        'if l_avg = l_check or r_avg = r_check then exit do
       
     loop
     
    dim as ubyte ptr lavg_ptr = cptr( ubyte ptr , strptr(l_avg) )
    dim as string l_ans = ""
    for a as longint = 1 to len(l_avg) step 1
            l_ans+= right(string(2,"0") +  str( *lavg_ptr ) , 2 )
            lavg_ptr+=1
    next
    l_ans = ltrim( l_ans,"0")
    dim as ubyte ptr ravg_ptr = cptr( ubyte ptr , strptr(r_avg) )
    dim as string r_ans = ""
    for a as longint = 1 to len(r_avg) step 1
            r_ans+= right(string(2,"0") +  str( *ravg_ptr ) , 2 )
            ravg_ptr+=1
    next
    r_ans = ltrim( r_ans,"0")
   
    time2 = timer
   
    dim as string my_answer = ""
    dim as string real_answer = multiplier_7( num1 , num2 )
    real_answer = left( real_answer , len(real_answer)-1 )
   
    dim as string difference1 = minus( l_ans , num2 )
    dim as string difference2 = minus( r_ans , real_answer )
   
    if difference2 = "0" then r_correct+=1
   
    print
    print "n1    = "  ; num1
    print "n2    = "  ; num2
    print "l_ans = " ; l_ans
    print
    print "real ans = "  ; real_answer
    print "my  ans  = " ; r_ans
    print
    print "L diff        =  " ; difference1
    print "R diff       =   " ; difference2
    print
    print "loops = " ; loops  ,, time2-time1 
    print
    print "correct " ; r_correct ; " out of" ; total
   
   
    if l_ans <> num2 then sleep
    if r_ans <> real_answer then sleep
   
    if inkey = chr(27) then exit do
    if inkey = " " then sleep
   
loop until inkey = chr(27)

sleep
end
'==================================================
'==================================================
function less_great ( n1 as string , n2 as string) as string
        dim as string char = "="
        if n1 = n2 then return char
        dim as ubyte ptr ubp1 = cptr( ubyte ptr , strptr(n1) )
        dim as ubyte ptr ubp2 = cptr( ubyte ptr , strptr(n2) )
        for a as longint = 1 to len(n1) step 1
            if *ubp1 > *ubp2 then char = ">" : exit for
            if *ubp1 < *ubp2 then char = "<" : exit for
            ubp1+=1
            ubp2+=1
        next
        return char
end function
'==================================================
'==================================================
function convert_to_pointers( n as string ) as string
   
    dim as string n1 = n
    dim as string n2
    dim as ubyte ptr ubp
    dim as ubyte val1
    dim as longint len_1
   
    n2 = string(len(n1) , chr(0))
    ubp = cptr(ubyte ptr,strptr(n2))
    len_1 = 0
    for a as longint = 0 to len(n1)-1 step 2
        val1  =  (n1[a+0]-48)*10
        val1+=  (n1[a+1]-48)*1
        *ubp = val1
        ubp+=1
        len_1+= 1
    next
    n2 = left(n2,len_1)
    return n2
end function
'==================================================
'==================================================
function make_equal( n as string) as string
    dim as string n1 = n
    dim as string str1
    dim as ulongint dec1
    do
        str1 = str( len(n1) / 2 )
        dec1 = instr(1,str1,".")
        if  dec1 <> 0 then n1 = "0" + n1
    loop until dec1 = 0
    return n1
end function
'==================================================
'==================================================
Function divide(n1 As String,n2 As String,decimal_places As integer,dpflag As String="s") As String
          Dim As String number=n1,divisor=n2
          dpflag=lcase(dpflag)
          'For MOD
          dim as integer modstop
          if dpflag="mod" then
              if len(n1)<len(n2) then return n1
              if len(n1)=len(n2) then
                  if n1<n2 then return n1
                  end if
              modstop=len(n1)-len(n2)+1
              end if
          if dpflag<>"mod" then
     If dpflag<>"s"  Then dpflag="raw"
     end if
        Dim runcount As integer
        '_______  LOOK UP TABLES ______________
        Dim Qmod(0 To 19) As Ubyte
        Dim bool(0 To 19) As Ubyte
        For z As Integer=0 To 19
    Qmod(z)=(z Mod 10+48)
    bool(z)=(-(10>z))
Next z
Dim answer As String   'THE ANSWER STRING 

'_______ SET THE DECIMAL WHERE IT SHOULD BE AT _______
Dim As String part1,part2
#macro set(decimal)
#macro insert(s,char,position)
If position > 0 And position <=Len(s) Then
part1=Mid$(s,1,position-1)
part2=Mid$(s,position)
s=part1+char+part2
End if
#endmacro
insert(answer,".",decpos)
  answer=thepoint+zeros+answer
If dpflag="raw" Then
    answer=Mid(answer,1,decimal_places)
    End if
#endmacro
'______________________________________________
'__________ SPLIT A STRING ABOUT A CHARACTRR __________
Dim As String var1,var2
    Dim pst As integer
      #macro split(stri,char,var1,var2)
    pst=Instr(stri,char)
    var1="":var2=""
    If pst<>0 Then
    var1=Rtrim(Mid(stri,1,pst),".")
    var2=Ltrim(Mid(stri,pst),".")
Else
    var1=stri
    End if
    #endmacro
   
       #macro Removepoint(s)
       split(s,".",var1,var2)
#endmacro
'__________ GET THE SIGN AND CLEAR THE -ve __________________
Dim sign As String
          If Left(number,1)="-" Xor Left (divisor,1)="-" Then sign="-"
            If Left(number,1)="-" Then  number=Ltrim(number,"-")
            If Left (divisor,1)="-" Then divisor=Ltrim(divisor,"-")
             
'DETERMINE THE DECIMAL POSITION BEFORE THE DIVISION
Dim As integer lennint,lenddec,lend,lenn,difflen
split(number,".",var1,var2)
lennint=Len(var1)
split(divisor,".",var1,var2)
lenddec=Len(var2)

If Instr(number,".") Then
    Removepoint(number)
    number=var1+var2
    End if
If Instr(divisor,".") Then
    Removepoint(divisor)
    divisor=var1+var2
    End if
Dim As integer numzeros
numzeros=Len(number)
number=Ltrim(number,"0"):divisor=Ltrim (divisor,"0")
numzeros=numzeros-Len(number)
lend=Len(divisor):lenn=Len(number)
If lend>lenn Then difflen=lend-lenn
Dim decpos As integer=lenddec+lennint-lend+2-numzeros 'THE POSITION INDICATOR
Dim _sgn As Byte=-Sgn(decpos)
If _sgn=0 Then _sgn=1
Dim As String thepoint=String(_sgn,".") 'DECIMAL AT START (IF)
Dim As String zeros=String(-decpos+1,"0")'ZEROS AT START (IF) e.g. .0009
if dpflag<>"mod" then
If Len(zeros) =0 Then dpflag="s"
end if
Dim As integer runlength
If Len(zeros) Then
     runlength=decimal_places
     answer=String(Len(zeros)+runlength+10,"0")
    If dpflag="raw" Then
        runlength=1
        answer=String(Len(zeros)+runlength+10,"0")
        If decimal_places>Len(zeros) Then
            runlength=runlength+(decimal_places-Len(zeros))
            answer=String(Len(zeros)+runlength+10,"0")
            End If
            End If

Else
decimal_places=decimal_places+decpos
runlength=decimal_places
answer=String(Len(zeros)+runlength+10,"0")
End if
'___________DECIMAL POSITION DETERMINED  _____________

'SET UP THE VARIABLES AND START UP CONDITIONS
number=number+String(difflen+decimal_places,"0")
        Dim count As integer
        Dim temp As String
        Dim copytemp As String
        Dim topstring As String
        Dim copytopstring As String
        Dim As integer lenf,lens
        Dim As Ubyte takeaway,subtractcarry
        Dim As integer n3,diff
       If Ltrim(divisor,"0")="" Then Return "Error :division by zero"   
        lens=Len(divisor)
         topstring=Left(number,lend)
         copytopstring=topstring
        Do
            count=0
        Do
            count=count+1
            copytemp=temp
   
            Do
'___________________ QUICK SUBTRACTION loop _________________             
           
lenf=Len(topstring)
If  lens<lenf=0 Then 'not
If Lens>lenf Then
temp= "done"
Exit Do
End if
If divisor>topstring Then
temp= "done"
Exit Do
End if
End if

  diff=lenf-lens
        temp=topstring
        subtractcarry=0
       
        For n3=lenf-1 To diff Step -1
            takeaway= topstring[n3]-divisor[n3-diff]+10-subtractcarry
            temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n3
        If subtractcarry=0 Then Exit Do
         If n3=-1 Then Exit Do
        For n3=n3 To 0 Step -1
            takeaway= topstring[n3]-38-subtractcarry
             temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            if subtractcarry=0 then exit do
            Next n3
        Exit Do
       
        Loop 'single run
        temp=Ltrim(temp,"0")
        If temp="" Then temp= "0"
            topstring=temp
        Loop Until temp="done"
     ' INDIVIDUAL CHARACTERS CARVED OFF ________________       
        runcount=runcount+1
       If count=1 Then
           topstring=copytopstring+Mid(number,lend+runcount,1)
           Else
       topstring=copytemp+Mid(number,lend+runcount,1)
   End If
       copytopstring=topstring
       topstring=Ltrim(topstring,"0")
       if dpflag="mod" then
       if runcount=modstop then
           if topstring="" then return "0"
           return mid(topstring,1,len(topstring)-1)
           end if
       end if
       answer[runcount-1]=count+47
       If topstring="" And runcount>Len(n1)+1 Then
           Exit Do
           End if
   Loop Until runcount=runlength+1
   
   ' END OF RUN TO REQUIRED DECIMAL PLACES
   set(decimal) 'PUT IN THE DECIMAL POINT
  'THERE IS ALWAYS A DECIMAL POINT SOMEWHERE IN THE ANSWER
  'NOW GET RID OF IT IF IT IS REDUNDANT
       answer=Rtrim(answer,"0")
       answer=Rtrim(answer,".")
       answer=Ltrim(answer,"0")
       If answer="" Then Return "0"
   Return sign+answer
End Function
'===============================================================================
'===============================================================================
Function half(fl As String) As String
    Dim As Ubyte main,carry,temp
    Dim As String sign   , s
    If Instr(fl,".")=0 Then s=fl+".0" Else s=fl+"0"
    If Instr(s,"-") Then sign="-":s=Ltrim(s,"-")
    Dim As String ans=s
    For z As Integer=0 To Len(s)-1
        If s[z]<>46 Then
            temp=(s[z]-48+carry)
            main=temp Shr 1
            carry=(temp And 1) Shl 3 +(temp And 1) Shl 1
            ans[z]=main+48
        End If
    Next z
    If Instr(ans,".") Then ans=Rtrim(ans,"0")
    ans=Rtrim(ans,".")
    ans=Ltrim(ans,"0")
    Return ans
End Function
'===============================================================================
'===============================================================================
'Dodicats plus & Minus functions
'===============================================================================
'===============================================================================
    Function plus(_num1 As String,_num2 As String) As String
        Dim  ADDQmod(0 To 19) As Ubyte
        Dim  ADDbool(0 To 19) As Ubyte
        For z As Integer=0 To 19
            ADDQmod(z)=(z Mod 10+48)
            ADDbool(z)=(-(10<=z))
        Next z
        Var _flag=0,n_=0
        Dim As Ubyte addup=Any,addcarry=Any
        #macro finish()
        answer=Ltrim(answer,"0")
        If _flag=1 Then Swap _num2,_num1
        Return answer
        #endmacro
        If Len(_num2)>Len(_num1) Then
            Swap _num2,_num1
            _flag=1
        End If
        Var diff=Len(_num1)-Len(_num2)
        Var answer="0"+_num1
        addcarry=0
        For n_=Len(_num1)-1 To diff Step -1
            addup=_num2[n_-diff]+_num1[n_]-96
            answer[n_+1]=ADDQmod(addup+addcarry)
            addcarry=ADDbool(addup+addcarry)
        Next n_
        If addcarry=0 Then
            finish()
        End If
        If n_=-1 Then
            answer[0]=addcarry+48
            finish()
            Endif
            For n_=n_ To 0 Step -1
                addup=_num1[n_]-48
                answer[n_+1]=ADDQmod(addup+addcarry)
                addcarry=ADDbool(addup+addcarry)
                If addcarry=0 Then Exit For
            Next n_
            answer[0]=addcarry+48
            finish()
        End Function
'===============================================================================
'===============================================================================
Function minus(NUM1 As String,NUM2 As String) As String
     'Dim As String copyfirstnum=mul_num_1,copysecondnum=mul_num_2
    Dim As Byte swapflag           
    Dim As Long lenf,lens
    Dim sign As String * 1
    'Dim As String part1,part2
    Dim bigger As Byte
     'set up tables
    Dim As Ubyte Qmod(0 To 19)
    Dim bool(0 To 19) As Ubyte

    For z As Integer=0 To 19
        Qmod(z)=cubyte(z Mod 10+48)
        bool(z)=cubyte(-(10>z))
    Next z
    lenf=Len(NUM1)
    lens=Len(NUM2)
    #macro compare(numbers)
        If Lens>lenf Then bigger= -1:Goto fin
        If Lens<lenf Then bigger =0:Goto fin
        If NUM2>NUM1 Then
            bigger=-1
        Else
            bigger= 0
        End If
        fin:
    #endmacro

    compare(numbers)
    If bigger Then
        sign="-"
        Swap NUM2,NUM1
        Swap lens,lenf
        swapflag=1
    Endif
    'lenf=Len(NUM1)
    'lens=Len(NUM2)
    Dim diff As Long=lenf-lens-Sgn(lenf-lens)
    Dim As String one,two,three
    three=NUM1
    two=String(lenf-lens,"0")+NUM2
    one=NUM1
    Dim As Long n2
    Dim As Ubyte takeaway,subtractcarry
    Dim As Ubyte ten=10
    'Dim z As Long
    subtractcarry=0
    Do
         For n2=lenf-1 To diff Step -1
           takeaway= one[n2]-two[n2]+ten-subtractcarry
           three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n2
        If subtractcarry=0 Then Exit Do
        If n2=-1 Then Exit Do
        For n2=n2 To 0 Step -1
            takeaway= one[n2]-two[n2]+ten-subtractcarry
            three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            Next n2
        Exit Do
    Loop
   
    three=Ltrim(three,"0")
    If three="" Then Return "0"
    If swapflag=1 Then Swap NUM1,NUM2
   
    Return sign+three
   
End Function
'===============================================================================
'===============================================================================
function multiplier_7(byref num1 as string, byref num2 as string) as string
   
    dim as string number1,number2
    dim as string answer,outtext
   
    dim as string int1,frac1,int2,frac2
    dim as ulongint dec,dec1,len1,len2
    dim as string str1
    dim as string sign1,sign2,outsign
   
    number1 = num1
    number2 = num2
   
    sign1 = left(number1,1)
    if sign1 = "+" or sign1 = "-" then number1 = mid(number1,2) else sign1 = ""
   
    sign2 = left(number2,1)
    if sign2 = "+" or sign2 = "-" then number2 = mid(number2,2) else sign2 = ""
   
    if (sign1 = sign2) then outsign = ""
    if (sign1 <> sign2) then outsign = "-"
   
    dec = instr(1,number1,".")
    if dec > 0 then
        int1 = left(number1,dec-1)
        frac1 = mid(number1,dec+1)
    else
        int1 = number1
        frac1 = ""
    end if
   
    dec = instr(1,number2,".")
    if dec > 0 then
        int2 = left(number2,dec-1)
        frac2 = mid(number2,dec+1)
    else
        int2 = number2
        frac2 = ""
    end if

    dec = len(frac1)+len(frac2)
    number1 = int1+frac1
    number2 = int2+frac2

    'swap numbers so that bigger number is number1 and smaller is number2
    if len(number2) > len(number1) then swap number1,number2
    if len(number1) = len(number2) then
        if val(left(number2,1)) > val(left(number1,1)) then swap number1,number2
    end if

    'make numbers equal multiple of 7 bytes
    do
        str1 = str(len(number1)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number1 = "0" + number1
    loop until dec1 = 0
    do
        str1 = str(len(number2)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number2 = "0" + number2
    loop until dec1 = 0
   
    'convert the numeric strings to use pointers
    'convert number1
    dim as string n1 = string(len(number1)*8,chr(0))
    dim as ulongint ptr ulp1
    ulp1 = cptr(ulongint ptr,strptr(n1))
    dim as longint val1
    dim as longint len_1 = 0
    dim as uinteger a
    for a = 0 to len(number1)-1 step 7
        val1 = (number1[a+0]-48)*1000000ull
        val1+= (number1[a+1]-48)*100000ull
        val1+= (number1[a+2]-48)*10000ull
        val1+= (number1[a+3]-48)*1000ull
        val1+= (number1[a+4]-48)*100ull
        val1+= (number1[a+5]-48)*10ull
        val1+= (number1[a+6]-48)*1ull
        *ulp1 = val1
        ulp1+=1
        len_1+=8
    next
    number1 = left(n1,len_1)
    n1=""
   
    'convert the numeric strings to use pointers
    'convert number2
    dim as string n2 = string(len(number2)*8,chr(0))
    dim as ulongint ptr ulp2
    ulp2 = cptr(ulongint ptr,strptr(n2))
    dim as longint val2
    dim as longint len_2 = 0
    for a = 0 to len(number2)-1 step 7
        val2 = (number2[a+0]-48)*1000000ull
        val2+= (number2[a+1]-48)*100000ull
        val2+= (number2[a+2]-48)*10000ull
        val2+= (number2[a+3]-48)*1000ull
        val2+= (number2[a+4]-48)*100ull
        val2+= (number2[a+5]-48)*10ull
        val2+= (number2[a+6]-48)*1ull
        *ulp2 = val2
        ulp2+=1
        len_2+=8
    next
    number2 = left(n2,len_2)
    n2=""
   
    'create accumulator
    answer = string( len(number1) + len(number2) + 8 , chr(0) )
    'dimension vars for the mul
    dim as longint ptr start1,stop1,start2,stop2 'use longint because the pointers go negative
    dim as longint ptr chk_1 , chk_2
    dim as longint ptr inc1,inc2
    dim as longint ptr outplace
    dim as ulongint carry
    dim as ulongint total
    dim as ulongint blocknumber1 = len(number1)/8
    dim as ulongint blocknumber2 = len(number2)/8
    dim as ulongint outblocks = len(answer)/8
   
    'set initial accumulator place
    outplace = cptr(longint ptr , strptr(answer)) + (outblocks - 1)
    'set initial pointers into number1
    start1 = cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    stop1 =  cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    'set initial pointers into number2
    start2 = cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    stop2 =  cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    'set comparison to beg of numbers
    chk_1 = cptr( longint ptr , strptr(number1))
    chk_2 = cptr( longint ptr , strptr(number2))
   
    'zero the carry
    carry = 0
   
    'begin looping thru strings multiplying
    do
        'set total to zero
        total = 0
        'we are going to be incrementing thru number2 while decrementing thru number1
        'working in opposite directions from start1 to stop1 and start2 to stop2
        'inc1 works from right to left in the top number1 string
        'inc2 works from start2 to stop 2, in the bottom number2 string, decrementing each loop.
        inc1 = start1
        inc2 = start2
        do
            total += *inc1 * *inc2
            inc1-= 1
            inc2+= 1
        loop until inc2 = stop2+1
   
        total = total + carry
        carry = total \ 1e7
        *outplace = total mod 1e7
        '*outplace = imod(total , 1e7)
       
        outplace -= 1
       
        'each loop we need to decrement stop1
        'if stop1 goes negative we reset it to zero and decrement stop2
        stop1 -= 1
        if stop1 < chk_1 then
            stop1 += 1
            stop2 -=1
            if stop2 < chk_2 then stop2+= 1
        end if
        'each loop we decrement start2 to the left
        start2 -= 1
        'if start2 goes negative we reset it to zero and decrement start1
        'start1 is the rightmost digit of number1 we need to multiply
        if start2 < chk_2 then
            start2 += 1
            start1 -= 1
            if start1 < chk_1 then start1+=1
        end if
   
    loop until outplace = cptr(ulongint ptr,strptr(answer))+1
   
    'put in the carry at the end
    if carry > 0  then *outplace = carry else *outplace = 0
   
    'convert answer back to ascii
    for a as ulongint = 1 to outblocks-1 step 1
        val1 = *outplace
        outplace +=1
        outtext = outtext + right("0000000" + str(val1),7)
    next   

    'put in the decimal point
    outtext = left(outtext,len(outtext)-dec) + "." +  mid(outtext,(len(outtext)-dec)+1)
    'trim leading zeros
    outtext = trim(outtext,"0") 'if multiplying by 1, we have a zero in front.
    outtext = outsign + outtext

    return outtext

end function
'===============================================================================
'===============================================================================

albert
Posts: 5676
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Dec 09, 2018 23:51

@Dodicat
@Richard

I got it working,,, But the size of the digits has to be greater than 4, 5 digits or higher....

Still got to figure out why it won't do 1's , 2's , 3's and 4's


Code: Select all


DECLARE FUNCTION multiplier_7(byref num1 as string, byref num2 as string) as string
Declare Function divide(n1 As String,n2 As String,decimal_places As integer,dpflag As String="s") As String

DECLARE Function minus(NUM1 As String,NUM2 As String) As String
Declare Function       plus( NUMber1 As String  ,  NUMber2 As String ) As String
Declare Function half(fl As String) As String


declare function convert_to_pointers( n as string ) as string
declare function make_equal( n as string) as string
declare function less_great ( n1 as string , n2 as string) as string

screen 19

dim as double time1 , time2

dim as longint size = 10

dim as longint total = 0
dim as longint r_correct = 0

do
   
    total+=1
   
    dim as string num1
    for a as longint =  1 to size step 1
        num1+=str(int(rnd*10))
    next
    if left(num1,1) = "0" then mid(num1,1,1) = str(int(rnd*9)+1)
   
    dim as string num2
    for a as longint =  1 to size step 1
        num2+=str(int(rnd*10))
    next
    if left(num2,1) = "0" then mid(num2,1,1) = str(int(rnd*9)+1)
   
    if len(num2) = len(num1) then if num2 > num1 then swap num1 , num2
    if len(num2) > len(num1) then swap num1 , num2
    if len(num2) = len(num1) then if val(left(num2,1)) > val(left(num1,1)) then swap num1,num2
   
    '==========================================================
    'declare vars
    '==========================================================
    time1 = timer
   
    dim as string test = num2
   
    dim as string l_bot = left(num2,1) + string( len(num2) - 1 , "0" )
    dim as string l_avg
    dim as string l_top =  plus( l_bot , l_bot )
   
    dim as string r_bot  = multiplier_7( num1 , left(num2,1) )
        r_bot = left( r_bot , len(r_bot) - 1 )
        r_bot+= string( len(num2)-1 , "0" )
    dim as string r_avg
    dim as string r_top  = plus( r_bot , r_bot )
   
    dim as string point_5 = half( num1 )
        if right(point_5 , 2 ) = ".5" then point_5 = left( point_5 , len(point_5) - 2 )
       
    '==========================================================
    'make all var strings a multiple of 18 digits
    '==========================================================
    test = make_equal( test )
   
    l_bot  = make_equal( l_bot )
    l_top  = make_equal( l_top )

    r_bot   = make_equal( r_bot )
    r_top   = make_equal( r_top )
   
    point_5 = make_equal( point_5 )
   
    '==========================================================
    'convert the numeric strings to use pointers
    '==========================================================
    test = convert_to_pointers( test )
   
    l_bot = convert_to_pointers( l_bot )
    l_top = convert_to_pointers( l_top )
   
    r_bot = convert_to_pointers( r_bot )
    r_top = convert_to_pointers( r_top )
   
    if len(l_top) > len(l_bot)  then
        l_bot = chr(0) + l_bot
        test   = chr(0) + test
    end if
    if len(r_top) > len(r_bot)  then
        r_bot = chr(0) + r_bot
    end if
   
    point_5 = convert_to_pointers( point_5 )
   
    '==========================================================
    '==========================================================
   
    dim as string char
    dim as ulongint loops = 0
    do
       
        loops+=1
       
        dim as string l_check = l_avg
        l_avg = string( len(l_top) , chr(0) )
        dim as ubyte l_val = 0
        dim as ubyte l_frac = 0
        dim as ubyte ptr lt_ptr  = cptr( ubyte ptr , strptr( l_top ) )
        dim as ubyte ptr la_ptr = cptr( ubyte ptr , strptr( l_avg ) )
        dim as ubyte ptr lb_ptr = cptr( ubyte ptr , strptr( l_bot ) )
            for a as longint = 1 to len( l_avg)  step 1
                if l_frac = 1 then *(la_ptr)+= 50
                l_val = ( *lt_ptr + *lb_ptr )
                *la_ptr+= ( l_val shr 1 )
                l_frac = l_val  and 1
                if *la_ptr > 99 then *la_ptr-= 100 : *(la_ptr-1)+= 1
                lt_ptr+=1
                la_ptr+=1
                lb_ptr+=1
            next
            if l_frac = 1 then  *(la_ptr-1)+= 1
            dim as longint l_place = 1
            for a as longint = len(l_avg) to 2  step -1
                if *(la_ptr-l_place) > 99 then *(la_ptr-l_place)-=100 : *(la_ptr-l_place-1)+=1
                l_place+=1
            next
       
           
        dim as string r_check = r_avg
        r_avg = string( len(r_top) , chr(0) )
        dim as ubyte r_val = 0
        dim as ubyte r_frac = 0
        dim as ubyte ptr rt_ptr  = cptr( ubyte ptr , strptr(r_top ) )
        dim as ubyte ptr ra_ptr = cptr( ubyte ptr , strptr( r_avg ) )
        dim as ubyte ptr rb_ptr = cptr( ubyte ptr , strptr( r_bot ) )
            for a as longint = 1 to len( r_avg) step 1
                if r_frac = 1 then *(ra_ptr)+= 50
                r_val = ( *rt_ptr + *rb_ptr )
                *ra_ptr+= ( r_val shr 1 )
                r_frac = r_val and 1
                if *ra_ptr > 99 then *ra_ptr-= 100 : *(ra_ptr-1)+=1
                rt_ptr+=1
                ra_ptr+=1
                rb_ptr+=1
            next
            if r_frac = 1 then *(ra_ptr-1)+=1
            dim as longint r_place = 1
            for a as longint = len(r_avg) to 2  step -1
                if *(ra_ptr-r_place) > 99 then *(ra_ptr-r_place)-=100 : *(ra_ptr-r_place-1)+=1
                r_place+=1
            next
           
            if l_frac = 1 then
                dim as ubyte ptr ubp = cptr( ubyte ptr , strptr( point_5 ) ) + len(point_5) - 1
                dim as longint place = 1
                for a as longint = len(point_5) to 1 step -1
                    *(ra_ptr-place)+=*ubp
                    ubp-=1
                    place+=1
                next
                r_place = 1
                for a as longint = len(r_avg) to 2  step -1
                    if *(ra_ptr-r_place) > 99 then *(ra_ptr-r_place)-=100 : *(ra_ptr-r_place-1)+=1
                    r_place+=1
                next
            end if
       
        char = less_great( l_avg , test )
       
        if inkey = " " then exit do
       
        if char = ">" then l_top = l_avg : r_top = r_avg
        if char = "<" then l_bot = l_avg : r_bot = r_avg
        if char = "=" then exit do
        'if l_avg = l_check or r_avg = r_check then exit do
       
       
       
     loop
     
    dim as ubyte ptr lavg_ptr = cptr( ubyte ptr , strptr(l_avg) )
    dim as string l_ans = ""
    for a as longint = 1 to len(l_avg) step 1
            l_ans+= right(string(2,"0") +  str( *lavg_ptr ) , 2 )
            lavg_ptr+=1
    next
    l_ans = ltrim( l_ans,"0")
   
    dim as ubyte ptr ravg_ptr = cptr( ubyte ptr , strptr(r_avg) )
    dim as string r_ans = ""
    for a as longint = 1 to len(r_avg) step 1
            r_ans+= right(string(2,"0") +  str( *ravg_ptr ) , 2 )
            ravg_ptr+=1
    next
    r_ans = ltrim( r_ans,"0")
   
    time2 = timer
   
    dim as string my_answer = ""
    dim as string real_answer = multiplier_7( num1 , num2 )
    real_answer = left( real_answer , len(real_answer)-1 )
   
    dim as string difference1 = minus( l_ans , num2 )
    dim as string difference2 = minus( r_ans , real_answer )
   
    if difference2 = "0" then r_correct+=1
   
    print
    print "n1    = "  ; num1
    print "n2    = "  ; num2
    print "l_ans = " ; l_ans
    print
    print "real ans = "  ; real_answer
    print "my  ans  = " ; r_ans
    print
    print "L diff        =  " ; difference1
    print "R diff       =   " ; difference2
    print
    print "loops = " ; loops  ,, time2-time1 
    print
    print "correct " ; r_correct ; " out of" ; total
   
    if l_ans <> num2 then sleep
    if r_ans <> real_answer then print left(num2,1) : sleep
   
    if inkey = chr(27) then exit do
    if inkey = " " then sleep
   
loop until inkey = chr(27)

sleep
end
'==================================================
'==================================================
function less_great ( n1 as string , n2 as string) as string
        dim as string char = "="
        if n1 = n2 then return char
        dim as ubyte ptr ubp1 = cptr( ubyte ptr , strptr(n1) )
        dim as ubyte ptr ubp2 = cptr( ubyte ptr , strptr(n2) )
        for a as longint = 1 to len(n1) step 1
            if *ubp1 > *ubp2 then char = ">" : exit for
            if *ubp1 < *ubp2 then char = "<" : exit for
            ubp1+=1
            ubp2+=1
        next
        return char
end function
'==================================================
'==================================================
function convert_to_pointers( n as string ) as string
   
    dim as string n1 = n
    dim as string n2
    dim as ubyte ptr ubp
    dim as ubyte val1
    dim as longint len_1
   
    n2 = string( len(n1) * 2 , chr(0) )
    ubp = cptr( ubyte ptr , strptr( n2 ) )
    len_1 = 0
    for a as longint = 0 to len(n1)-1 step 2
        val1  =  (n1[a+0]-48)*10
        val1+=  (n1[a+1]-48)*1
        *ubp = val1
        ubp+=1
        len_1+= 1
    next
    n2 = left( n2 , len_1 )
    return n2
end function
'==================================================
'==================================================
function make_equal( n as string) as string
    dim as string n1 = n
    dim as string str1
    dim as ulongint dec1
    do
        str1 = str( len(n1) / 2 )
        dec1 = instr(1,str1,".")
        if  dec1 <> 0 then n1 = "0" + n1
    loop until dec1 = 0
    return n1
end function
'==================================================
'==================================================
Function divide(n1 As String,n2 As String,decimal_places As integer,dpflag As String="s") As String
          Dim As String number=n1,divisor=n2
          dpflag=lcase(dpflag)
          'For MOD
          dim as integer modstop
          if dpflag="mod" then
              if len(n1)<len(n2) then return n1
              if len(n1)=len(n2) then
                  if n1<n2 then return n1
                  end if
              modstop=len(n1)-len(n2)+1
              end if
          if dpflag<>"mod" then
     If dpflag<>"s"  Then dpflag="raw"
     end if
        Dim runcount As integer
        '_______  LOOK UP TABLES ______________
        Dim Qmod(0 To 19) As Ubyte
        Dim bool(0 To 19) As Ubyte
        For z As Integer=0 To 19
    Qmod(z)=(z Mod 10+48)
    bool(z)=(-(10>z))
Next z
Dim answer As String   'THE ANSWER STRING 

'_______ SET THE DECIMAL WHERE IT SHOULD BE AT _______
Dim As String part1,part2
#macro set(decimal)
#macro insert(s,char,position)
If position > 0 And position <=Len(s) Then
part1=Mid$(s,1,position-1)
part2=Mid$(s,position)
s=part1+char+part2
End if
#endmacro
insert(answer,".",decpos)
  answer=thepoint+zeros+answer
If dpflag="raw" Then
    answer=Mid(answer,1,decimal_places)
    End if
#endmacro
'______________________________________________
'__________ SPLIT A STRING ABOUT A CHARACTRR __________
Dim As String var1,var2
    Dim pst As integer
      #macro split(stri,char,var1,var2)
    pst=Instr(stri,char)
    var1="":var2=""
    If pst<>0 Then
    var1=Rtrim(Mid(stri,1,pst),".")
    var2=Ltrim(Mid(stri,pst),".")
Else
    var1=stri
    End if
    #endmacro
   
       #macro Removepoint(s)
       split(s,".",var1,var2)
#endmacro
'__________ GET THE SIGN AND CLEAR THE -ve __________________
Dim sign As String
          If Left(number,1)="-" Xor Left (divisor,1)="-" Then sign="-"
            If Left(number,1)="-" Then  number=Ltrim(number,"-")
            If Left (divisor,1)="-" Then divisor=Ltrim(divisor,"-")
             
'DETERMINE THE DECIMAL POSITION BEFORE THE DIVISION
Dim As integer lennint,lenddec,lend,lenn,difflen
split(number,".",var1,var2)
lennint=Len(var1)
split(divisor,".",var1,var2)
lenddec=Len(var2)

If Instr(number,".") Then
    Removepoint(number)
    number=var1+var2
    End if
If Instr(divisor,".") Then
    Removepoint(divisor)
    divisor=var1+var2
    End if
Dim As integer numzeros
numzeros=Len(number)
number=Ltrim(number,"0"):divisor=Ltrim (divisor,"0")
numzeros=numzeros-Len(number)
lend=Len(divisor):lenn=Len(number)
If lend>lenn Then difflen=lend-lenn
Dim decpos As integer=lenddec+lennint-lend+2-numzeros 'THE POSITION INDICATOR
Dim _sgn As Byte=-Sgn(decpos)
If _sgn=0 Then _sgn=1
Dim As String thepoint=String(_sgn,".") 'DECIMAL AT START (IF)
Dim As String zeros=String(-decpos+1,"0")'ZEROS AT START (IF) e.g. .0009
if dpflag<>"mod" then
If Len(zeros) =0 Then dpflag="s"
end if
Dim As integer runlength
If Len(zeros) Then
     runlength=decimal_places
     answer=String(Len(zeros)+runlength+10,"0")
    If dpflag="raw" Then
        runlength=1
        answer=String(Len(zeros)+runlength+10,"0")
        If decimal_places>Len(zeros) Then
            runlength=runlength+(decimal_places-Len(zeros))
            answer=String(Len(zeros)+runlength+10,"0")
            End If
            End If

Else
decimal_places=decimal_places+decpos
runlength=decimal_places
answer=String(Len(zeros)+runlength+10,"0")
End if
'___________DECIMAL POSITION DETERMINED  _____________

'SET UP THE VARIABLES AND START UP CONDITIONS
number=number+String(difflen+decimal_places,"0")
        Dim count As integer
        Dim temp As String
        Dim copytemp As String
        Dim topstring As String
        Dim copytopstring As String
        Dim As integer lenf,lens
        Dim As Ubyte takeaway,subtractcarry
        Dim As integer n3,diff
       If Ltrim(divisor,"0")="" Then Return "Error :division by zero"   
        lens=Len(divisor)
         topstring=Left(number,lend)
         copytopstring=topstring
        Do
            count=0
        Do
            count=count+1
            copytemp=temp
   
            Do
'___________________ QUICK SUBTRACTION loop _________________             
           
lenf=Len(topstring)
If  lens<lenf=0 Then 'not
If Lens>lenf Then
temp= "done"
Exit Do
End if
If divisor>topstring Then
temp= "done"
Exit Do
End if
End if

  diff=lenf-lens
        temp=topstring
        subtractcarry=0
       
        For n3=lenf-1 To diff Step -1
            takeaway= topstring[n3]-divisor[n3-diff]+10-subtractcarry
            temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n3
        If subtractcarry=0 Then Exit Do
         If n3=-1 Then Exit Do
        For n3=n3 To 0 Step -1
            takeaway= topstring[n3]-38-subtractcarry
             temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            if subtractcarry=0 then exit do
            Next n3
        Exit Do
       
        Loop 'single run
        temp=Ltrim(temp,"0")
        If temp="" Then temp= "0"
            topstring=temp
        Loop Until temp="done"
     ' INDIVIDUAL CHARACTERS CARVED OFF ________________       
        runcount=runcount+1
       If count=1 Then
           topstring=copytopstring+Mid(number,lend+runcount,1)
           Else
       topstring=copytemp+Mid(number,lend+runcount,1)
   End If
       copytopstring=topstring
       topstring=Ltrim(topstring,"0")
       if dpflag="mod" then
       if runcount=modstop then
           if topstring="" then return "0"
           return mid(topstring,1,len(topstring)-1)
           end if
       end if
       answer[runcount-1]=count+47
       If topstring="" And runcount>Len(n1)+1 Then
           Exit Do
           End if
   Loop Until runcount=runlength+1
   
   ' END OF RUN TO REQUIRED DECIMAL PLACES
   set(decimal) 'PUT IN THE DECIMAL POINT
  'THERE IS ALWAYS A DECIMAL POINT SOMEWHERE IN THE ANSWER
  'NOW GET RID OF IT IF IT IS REDUNDANT
       answer=Rtrim(answer,"0")
       answer=Rtrim(answer,".")
       answer=Ltrim(answer,"0")
       If answer="" Then Return "0"
   Return sign+answer
End Function
'===============================================================================
'===============================================================================
Function half(fl As String) As String
    Dim As Ubyte main,carry,temp
    Dim As String sign   , s
    If Instr(fl,".")=0 Then s=fl+".0" Else s=fl+"0"
    If Instr(s,"-") Then sign="-":s=Ltrim(s,"-")
    Dim As String ans=s
    For z As Integer=0 To Len(s)-1
        If s[z]<>46 Then
            temp=(s[z]-48+carry)
            main=temp Shr 1
            carry=(temp And 1) Shl 3 +(temp And 1) Shl 1
            ans[z]=main+48
        End If
    Next z
    If Instr(ans,".") Then ans=Rtrim(ans,"0")
    ans=Rtrim(ans,".")
    ans=Ltrim(ans,"0")
    Return ans
End Function
'===============================================================================
'===============================================================================
'Dodicats plus & Minus functions
'===============================================================================
'===============================================================================
    Function plus(_num1 As String,_num2 As String) As String
        Dim  ADDQmod(0 To 19) As Ubyte
        Dim  ADDbool(0 To 19) As Ubyte
        For z As Integer=0 To 19
            ADDQmod(z)=(z Mod 10+48)
            ADDbool(z)=(-(10<=z))
        Next z
        Var _flag=0,n_=0
        Dim As Ubyte addup=Any,addcarry=Any
        #macro finish()
        answer=Ltrim(answer,"0")
        If _flag=1 Then Swap _num2,_num1
        Return answer
        #endmacro
        If Len(_num2)>Len(_num1) Then
            Swap _num2,_num1
            _flag=1
        End If
        Var diff=Len(_num1)-Len(_num2)
        Var answer="0"+_num1
        addcarry=0
        For n_=Len(_num1)-1 To diff Step -1
            addup=_num2[n_-diff]+_num1[n_]-96
            answer[n_+1]=ADDQmod(addup+addcarry)
            addcarry=ADDbool(addup+addcarry)
        Next n_
        If addcarry=0 Then
            finish()
        End If
        If n_=-1 Then
            answer[0]=addcarry+48
            finish()
            Endif
            For n_=n_ To 0 Step -1
                addup=_num1[n_]-48
                answer[n_+1]=ADDQmod(addup+addcarry)
                addcarry=ADDbool(addup+addcarry)
                If addcarry=0 Then Exit For
            Next n_
            answer[0]=addcarry+48
            finish()
        End Function
'===============================================================================
'===============================================================================
Function minus(NUM1 As String,NUM2 As String) As String
     'Dim As String copyfirstnum=mul_num_1,copysecondnum=mul_num_2
    Dim As Byte swapflag           
    Dim As Long lenf,lens
    Dim sign As String * 1
    'Dim As String part1,part2
    Dim bigger As Byte
     'set up tables
    Dim As Ubyte Qmod(0 To 19)
    Dim bool(0 To 19) As Ubyte

    For z As Integer=0 To 19
        Qmod(z)=cubyte(z Mod 10+48)
        bool(z)=cubyte(-(10>z))
    Next z
    lenf=Len(NUM1)
    lens=Len(NUM2)
    #macro compare(numbers)
        If Lens>lenf Then bigger= -1:Goto fin
        If Lens<lenf Then bigger =0:Goto fin
        If NUM2>NUM1 Then
            bigger=-1
        Else
            bigger= 0
        End If
        fin:
    #endmacro

    compare(numbers)
    If bigger Then
        sign="-"
        Swap NUM2,NUM1
        Swap lens,lenf
        swapflag=1
    Endif
    'lenf=Len(NUM1)
    'lens=Len(NUM2)
    Dim diff As Long=lenf-lens-Sgn(lenf-lens)
    Dim As String one,two,three
    three=NUM1
    two=String(lenf-lens,"0")+NUM2
    one=NUM1
    Dim As Long n2
    Dim As Ubyte takeaway,subtractcarry
    Dim As Ubyte ten=10
    'Dim z As Long
    subtractcarry=0
    Do
         For n2=lenf-1 To diff Step -1
           takeaway= one[n2]-two[n2]+ten-subtractcarry
           three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n2
        If subtractcarry=0 Then Exit Do
        If n2=-1 Then Exit Do
        For n2=n2 To 0 Step -1
            takeaway= one[n2]-two[n2]+ten-subtractcarry
            three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            Next n2
        Exit Do
    Loop
   
    three=Ltrim(three,"0")
    If three="" Then Return "0"
    If swapflag=1 Then Swap NUM1,NUM2
   
    Return sign+three
   
End Function
'===============================================================================
'===============================================================================
function multiplier_7(byref num1 as string, byref num2 as string) as string
   
    dim as string number1,number2
    dim as string answer,outtext
   
    dim as string int1,frac1,int2,frac2
    dim as ulongint dec,dec1,len1,len2
    dim as string str1
    dim as string sign1,sign2,outsign
   
    number1 = num1
    number2 = num2
   
    sign1 = left(number1,1)
    if sign1 = "+" or sign1 = "-" then number1 = mid(number1,2) else sign1 = ""
   
    sign2 = left(number2,1)
    if sign2 = "+" or sign2 = "-" then number2 = mid(number2,2) else sign2 = ""
   
    if (sign1 = sign2) then outsign = ""
    if (sign1 <> sign2) then outsign = "-"
   
    dec = instr(1,number1,".")
    if dec > 0 then
        int1 = left(number1,dec-1)
        frac1 = mid(number1,dec+1)
    else
        int1 = number1
        frac1 = ""
    end if
   
    dec = instr(1,number2,".")
    if dec > 0 then
        int2 = left(number2,dec-1)
        frac2 = mid(number2,dec+1)
    else
        int2 = number2
        frac2 = ""
    end if

    dec = len(frac1)+len(frac2)
    number1 = int1+frac1
    number2 = int2+frac2

    'swap numbers so that bigger number is number1 and smaller is number2
    if len(number2) > len(number1) then swap number1,number2
    if len(number1) = len(number2) then
        if val(left(number2,1)) > val(left(number1,1)) then swap number1,number2
    end if

    'make numbers equal multiple of 7 bytes
    do
        str1 = str(len(number1)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number1 = "0" + number1
    loop until dec1 = 0
    do
        str1 = str(len(number2)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number2 = "0" + number2
    loop until dec1 = 0
   
    'convert the numeric strings to use pointers
    'convert number1
    dim as string n1 = string(len(number1)*8,chr(0))
    dim as ulongint ptr ulp1
    ulp1 = cptr(ulongint ptr,strptr(n1))
    dim as longint val1
    dim as longint len_1 = 0
    dim as uinteger a
    for a = 0 to len(number1)-1 step 7
        val1 = (number1[a+0]-48)*1000000ull
        val1+= (number1[a+1]-48)*100000ull
        val1+= (number1[a+2]-48)*10000ull
        val1+= (number1[a+3]-48)*1000ull
        val1+= (number1[a+4]-48)*100ull
        val1+= (number1[a+5]-48)*10ull
        val1+= (number1[a+6]-48)*1ull
        *ulp1 = val1
        ulp1+=1
        len_1+=8
    next
    number1 = left(n1,len_1)
    n1=""
   
    'convert the numeric strings to use pointers
    'convert number2
    dim as string n2 = string(len(number2)*8,chr(0))
    dim as ulongint ptr ulp2
    ulp2 = cptr(ulongint ptr,strptr(n2))
    dim as longint val2
    dim as longint len_2 = 0
    for a = 0 to len(number2)-1 step 7
        val2 = (number2[a+0]-48)*1000000ull
        val2+= (number2[a+1]-48)*100000ull
        val2+= (number2[a+2]-48)*10000ull
        val2+= (number2[a+3]-48)*1000ull
        val2+= (number2[a+4]-48)*100ull
        val2+= (number2[a+5]-48)*10ull
        val2+= (number2[a+6]-48)*1ull
        *ulp2 = val2
        ulp2+=1
        len_2+=8
    next
    number2 = left(n2,len_2)
    n2=""
   
    'create accumulator
    answer = string( len(number1) + len(number2) + 8 , chr(0) )
    'dimension vars for the mul
    dim as longint ptr start1,stop1,start2,stop2 'use longint because the pointers go negative
    dim as longint ptr chk_1 , chk_2
    dim as longint ptr inc1,inc2
    dim as longint ptr outplace
    dim as ulongint carry
    dim as ulongint total
    dim as ulongint blocknumber1 = len(number1)/8
    dim as ulongint blocknumber2 = len(number2)/8
    dim as ulongint outblocks = len(answer)/8
   
    'set initial accumulator place
    outplace = cptr(longint ptr , strptr(answer)) + (outblocks - 1)
    'set initial pointers into number1
    start1 = cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    stop1 =  cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    'set initial pointers into number2
    start2 = cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    stop2 =  cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    'set comparison to beg of numbers
    chk_1 = cptr( longint ptr , strptr(number1))
    chk_2 = cptr( longint ptr , strptr(number2))
   
    'zero the carry
    carry = 0
   
    'begin looping thru strings multiplying
    do
        'set total to zero
        total = 0
        'we are going to be incrementing thru number2 while decrementing thru number1
        'working in opposite directions from start1 to stop1 and start2 to stop2
        'inc1 works from right to left in the top number1 string
        'inc2 works from start2 to stop 2, in the bottom number2 string, decrementing each loop.
        inc1 = start1
        inc2 = start2
        do
            total += *inc1 * *inc2
            inc1-= 1
            inc2+= 1
        loop until inc2 = stop2+1
   
        total = total + carry
        carry = total \ 1e7
        *outplace = total mod 1e7
        '*outplace = imod(total , 1e7)
       
        outplace -= 1
       
        'each loop we need to decrement stop1
        'if stop1 goes negative we reset it to zero and decrement stop2
        stop1 -= 1
        if stop1 < chk_1 then
            stop1 += 1
            stop2 -=1
            if stop2 < chk_2 then stop2+= 1
        end if
        'each loop we decrement start2 to the left
        start2 -= 1
        'if start2 goes negative we reset it to zero and decrement start1
        'start1 is the rightmost digit of number1 we need to multiply
        if start2 < chk_2 then
            start2 += 1
            start1 -= 1
            if start1 < chk_1 then start1+=1
        end if
   
    loop until outplace = cptr(ulongint ptr,strptr(answer))+1
   
    'put in the carry at the end
    if carry > 0  then *outplace = carry else *outplace = 0
   
    'convert answer back to ascii
    for a as ulongint = 1 to outblocks-1 step 1
        val1 = *outplace
        outplace +=1
        outtext = outtext + right("0000000" + str(val1),7)
    next   

    'put in the decimal point
    outtext = left(outtext,len(outtext)-dec) + "." +  mid(outtext,(len(outtext)-dec)+1)
    'trim leading zeros
    outtext = trim(outtext,"0") 'if multiplying by 1, we have a zero in front.
    outtext = outsign + outtext

    return outtext

end function
'===============================================================================
'===============================================================================


Return to “General”

Who is online

Users browsing this forum: marcov and 3 guests