Squares

General FreeBASIC programming questions.
Locked
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

If yuo want 8 by 16 then you must expand the ascii array to hold it.

Code: Select all

 
declare sub draws( text as string , h_place as integer , y_place as integer , fg as ulongint , bg as ulongint )


'set up graphics screen
'===============================================================================
Dim as Integer xres,yres
'screen 19
screeninfo xres,yres
Screenres xres,yres,32,1,1
width xres/8 , yres/16

'get ascii characters into 3D array for printing to screen
'===============================================================================
dim shared as ubyte ASCII(0 to 255, 1 to 8, 1 to 16)
dim as integer char
for char as integer = 0 to 255
    cls
    draw string(0,0) , chr(char), 150
    for x as integer = 0 to 7
        for y as integer = 0 to 15'7
            ASCII(char,x+1,y+1)=point(x,y)
        next
    next
next
    
    'print some introductory text.
    dim as string text = string(40,chr(177))
    for y_place as integer = -5 to yres step 40
        draws(text , -5 , y_place , rgb(0,0,100) , rgb(0,0,150))
    next
    
    text = "!!--SNAKEY--!!"
    draws(text , (xres/2) - (len(text)*40/2) , yres/2 , rgb(100,0,100) , rgb(150,150,150))
   
    'i'm getting 96 rows and 170 columns , 
    ' but printing to 170 doesn't fill last block
    ' printing to 171 overflows the line.
    for a as ulongint = 0 to 96
        locate a,170
        color rgb(100,150,100) , rgb(0,0,0)
        print "*";
    next
    
sleep 
END
'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
'subs & functions below here
'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
Sub draws( text as string , h_place as integer , y_place as integer , fg as ulongint , bg as ulongint )
    dim as ubyte char
    for a as integer = 1 to len(text)
        char = asc(mid(text,a,1))
        for x as integer = 1 to 8
            for y as integer = 1 to 16
                    line( (h_place)+(x*5)+(a*40)-40 , (y*5)+(y_place) ) - ( (h_place)+(x*5)+(a*40)-40+4 , (y*5)+(y_place)+4 ), fg , bf
                if ASCII(char,x,y)<>0 then 
                    line( (h_place)+(x*5)+(a*40)-40 , (y*5)+(y_place) ) - ( (h_place)+(x*5)+(a*40)-40+4 , (y*5)+(y_place)+4 ), bg , bf
                end if
            next
        next
    next 
end sub
 
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

Your rotating 8x16 text looks pretty good, on my box..

I was wondering how to make it circle around a circle ,
where it starts at maybe 0 degrees and the head of the snake circles all the way around the circle to 360 and starts over.

I think it would be a cool introductory screen.
Another idea maybe using your first blue waves and having it look like a cobra swimming back & forth.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Using drawstring maybe something like:

Code: Select all


Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour As Uinteger,size As Single,textangle As Single=0,charangle As Single=0,im As Any Pointer=0)
    Type point2d
        As Single x,y
        As Uinteger col
    End Type
    Dim As Integer flag,codenum=256 
    if instr(text,"|") then flag=1
    Static As Integer runflag
    Static As point2d infoarray()
    Redim Preserve As point2d infoarray(128,codenum) '64 = 8 x 8 pixel size
    If runflag=0 Then   '                  'scan codenum of codepage once
        Dim As Uinteger background=0
        'Screenres 10,10  '8 x 8 pixels on this screen
        screen 8
        width 640\8,200\16  'new setting to 8 by 16 pixels
        Dim count As Integer
        For ch As Integer=1 To codenum
            Cls
            Draw String(1,1),Chr(ch)
            For x As Integer=1 To 8  'scan for characters
                For y As Integer=1 To 16
                    If Point(x,y)<>background Then
                        count=count+1
                        infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
                    End If 
                Next y
            Next x
            count=0
        Next ch
        runflag=1 
    End If
    If size=0 Then Exit Sub
    Dim As point2d temp(1 To 128,codenum),np
    Dim As Single cr= 0.01745329 'degs to radians
    #macro rotate(p1,p2,a,d)
    np.col=p2.col
    np.x=d*(Cos(a*cr)*(p2.x-p1.x)-Sin(a*cr)*(p2.y-p1.y)) +p1.x
    np.y=d*(Sin(a*cr)*(p2.x-p1.x)+Cos(a*cr)*(p2.y-p1.y)) +p1.y
    #endmacro
    
    Dim As point2d cpt(1 To 128),c=Type<point2d>(xpos,ypos),c2
    Dim As Integer dx=xpos,dy=ypos
    For z6 As Integer=1 To Len(text)
        var asci=text[z6-1]
        If asci=124 Then 
            if charangle<>0 then xpos=xpos+12*sin(charangle*cr)
            dx=xpos:dy=dy+16:Goto skip 'pipe | for new line
        End If
        For _x1 As Integer=1 To 128
            temp(_x1,asci).x=infoarray(_x1,asci).x+dx
            temp(_x1,asci).y=infoarray(_x1,asci).y+dy
            temp(_x1,asci).col=colour
            rotate(c,temp(_x1,asci),textangle,size)
            cpt(_x1)=np
            var copyy=np.y
            If charangle<>0 Then
              if flag then var p=1 else  p=(z6-1)
c2=Type<point2d>(xpos+(size*8)*p*(Cos(textangle*cr)),ypos+(size*8)*p*(Sin(textangle*cr))) 
                rotate(c2,cpt(_x1),charangle,1)
               if flag then np.y=copyy
                cpt(_x1)=np
            End If
            If infoarray(_x1,asci).x<>0 Then 'paint only relevant points 
                If Abs(size)>1 Then
                    line(cpt(_x1).x-size/2,cpt(_x1).y-size/2)-(cpt(_x1).x+size/2,cpt(_x1).y+size/2),cpt(_x1).col,bf
                Else
                    Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).col
                End If
            End If
        Next _x1
        
        dx=dx+9+4*(sin(charangle*cr))*flag
        skip:
    Next z6 
End Sub
Sub init Constructor 'automatic loader
    drawstring(0,0,"",0,0)
    Screen 0
End Sub

Function framecounter() As Integer
    Var t1=Timer,t2=t1
    Static As Double t3,frames,answer
    frames=frames+1
    If (t2-t3)>=1 Then
        t3=t2
        answer=frames
        frames=0
    End If
    Return answer
End Function
Function regulate(MyFps As Integer,Byref fps As Integer) As Integer
    fps=framecounter
    Static As Double timervalue
    Static As Double delta,lastsleeptime,sleeptime
    Var k=1/myfps
    If Abs(fps-myfps)>1 Then
        If fps<Myfps Then delta=delta-k Else delta=delta+k
    End If
    sleeptime=lastsleeptime+((1/myfps)-(Timer-timervalue))*(2000)+delta
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function
#define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)
dim as integer xres,yres
screen 20,32
screeninfo xres,yres
dim as double pi=4*atn(1)
dim as double rot=7*pi
dim as double inc
dim as integer fps
do
    var sleepytime=regulate(30,fps)
    inc=inc+.1
    screenlock
    cls
for z as double=inc to rot+inc step rot/250
    var angledegrees=z*180/pi
    var radius=map(inc,(rot+inc),z,30,300)
    var xpos=xres/2+radius*cos(z)
    var ypos=yres/2+radius*sin(z)
    var size=map(inc,(rot+inc),z,.5,3)
    var col=map(inc,(rot+inc),z,20,250)
    drawstring xpos,ypos,"<+>",rgb(col,250-col,col),size,angledegrees,
next z
drawstring 10,10,"FPS=  " & fps,rgb(0,200,0),2
screenunlock
sleep sleepytime,1
loop until len(inkey)

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

Re: Squares

Post by albert »

@Dodicat
I works pretty good but i'm only getting 17 FPS now.. I set it to print 3 different chars so I could vary the color at each.
Now to put a head on the thing...

Code: Select all


Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour As Uinteger,size As Single,textangle As Single=0,charangle As Single=0,im As Any Pointer=0)
    Type point2d
        As Single x,y
        As Uinteger col
    End Type
    Dim As Integer flag,codenum=256 
    if instr(text,"|") then flag=1
    Static As Integer runflag
    Static As point2d infoarray()
    Redim Preserve As point2d infoarray(128,codenum) '64 = 8 x 8 pixel size
    If runflag=0 Then   '                  'scan codenum of codepage once
        Dim As Uinteger background=0
        'Screenres 10,10  '8 x 8 pixels on this screen
        screen 8
        width 640\8,200\16  'new setting to 8 by 16 pixels
        Dim count As Integer
        For ch As Integer=1 To codenum
            Cls
            Draw String(1,1),Chr(ch)
            For x As Integer=1 To 8  'scan for characters
                For y As Integer=1 To 16
                    If Point(x,y)<>background Then
                        count=count+1
                        infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
                    End If 
                Next y
            Next x
            count=0
        Next ch
        runflag=1 
    End If
    If size=0 Then Exit Sub
    Dim As point2d temp(1 To 128,codenum),np
    Dim As Single cr= 0.01745329 'degs to radians
    #macro rotate(p1,p2,a,d)
    np.col=p2.col
    np.x=d*(Cos(a*cr)*(p2.x-p1.x)-Sin(a*cr)*(p2.y-p1.y)) +p1.x
    np.y=d*(Sin(a*cr)*(p2.x-p1.x)+Cos(a*cr)*(p2.y-p1.y)) +p1.y
    #endmacro
    
    Dim As point2d cpt(1 To 128),c=Type<point2d>(xpos,ypos),c2
    Dim As Integer dx=xpos,dy=ypos
    For z6 As Integer=1 To Len(text)
        var asci=text[z6-1]
        If asci=124 Then 
            if charangle<>0 then xpos=xpos+12*sin(charangle*cr)
            dx=xpos:dy=dy+16:Goto skip 'pipe | for new line
        End If
        For _x1 As Integer=1 To 128
            temp(_x1,asci).x=infoarray(_x1,asci).x+dx
            temp(_x1,asci).y=infoarray(_x1,asci).y+dy
            temp(_x1,asci).col=colour
            rotate(c,temp(_x1,asci),textangle,size)
            cpt(_x1)=np
            var copyy=np.y
            If charangle<>0 Then
              if flag then var p=1 else  p=(z6-1)
c2=Type<point2d>(xpos+(size*8)*p*(Cos(textangle*cr)),ypos+(size*8)*p*(Sin(textangle*cr))) 
                rotate(c2,cpt(_x1),charangle,1)
               if flag then np.y=copyy
                cpt(_x1)=np
            End If
            If infoarray(_x1,asci).x<>0 Then 'paint only relevant points 
                If Abs(size)>1 Then
                    line(cpt(_x1).x-size/2,cpt(_x1).y-size/2)-(cpt(_x1).x+size/2,cpt(_x1).y+size/2),cpt(_x1).col,bf
                Else
                    Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).col
                End If
            End If
        Next _x1
        
        dx=dx+9+4*(sin(charangle*cr))*flag
        skip:
    Next z6 
End Sub

Sub init Constructor 'automatic loader
    drawstring(0,0,"",0,0)
    Screen 0
End Sub

Function framecounter() As Integer
    Var t1=Timer,t2=t1
    Static As Double t3,frames,answer
    frames=frames+1
    If (t2-t3)>=1 Then
        t3=t2
        answer=frames
        frames=0
    End If
    Return answer
End Function

Function regulate(MyFps As Integer,Byref fps As Integer) As Integer
    fps=framecounter
    Static As Double timervalue
    Static As Double delta,lastsleeptime,sleeptime
    Var k=1/myfps
    If Abs(fps-myfps)>1 Then
        If fps<Myfps Then delta=delta-k Else delta=delta+k
    End If
    sleeptime=lastsleeptime+((1/myfps)-(Timer-timervalue))*(2000)+delta
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

#define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)
dim as integer xres,yres
'screen 20,32
screeninfo xres,yres
screenres xres,yres,32,0,1

dim as double pi=4*atn(1)
dim as double rot=7*pi
dim as double inc
dim as integer fps
do
    var sleepytime=regulate(32,fps)
    inc=inc+.1
    screenlock
    cls
    for z as double=inc to rot+inc step rot/250
        var angledegrees=z*180/pi
        var radius=map(inc,(rot+inc),z,30,300)
            
            var xpos1=xres/2+ ((radius+00)*cos(z))
            var ypos1=yres/2+ ((radius+00)*sin(z))
            
            var xpos2=xres/2+ ((radius+15)*cos(z))
            var ypos2=yres/2+ ((radius+15)*sin(z))
            
            var xpos3=xres/2+ ((radius+30)*cos(z))
            var ypos3=yres/2+ ((radius+30)*sin(z))
        
        var size=map(inc,(rot+inc),z,1.5,3)
        var col=map(inc,(rot+inc),z,120,250)
        
        drawstring xpos1,ypos1 , "(" , rgb( col/1.5 ,col/1.5 , 75 ), size, angledegrees,
        drawstring xpos2,ypos2 , "*" , rgb( col/2   ,col/2   , 75 ), size, angledegrees,
        drawstring xpos3,ypos3 , ")" , rgb( col/1.5 ,col/1.5 , 75 ), size, angledegrees,

    next z
    
    var text = "!!--SNAKEY--!!"
    if int(inc) mod 2 = 0 then drawstring (xres/2)-((len(text)*70)/2),yres/2.5 , text , rgb(200,200,0) , 8 ,0,
    
    drawstring 10,10,"FPS=  " & fps,rgb(0,200,0),2
    screenunlock
    sleep sleepytime,1
loop until len(inkey)

sleep
 
How do you modify drawstring so you can specify foreground and background colors of the character ???
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Hi Albert.
You can use a head like this.
I've used my old drawstring here, 8 X 8 pixels.
It's a bit faster but different quality.
I also have a drawstring which rotates the actual pixel boxes, but it only gives about 10 fps here.

Code: Select all

 
'old drawstring
Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour As Uinteger,size As Single,textangle As Single=0,charangle As Single=0,im As Any Pointer=0)
    Type point2d
        As Single x,y
        As Uinteger col
    End Type
    Dim As Integer flag,codenum=256 
    if instr(text,"|") then flag=1
    Static As Integer runflag
    Static As point2d infoarray()
    Redim Preserve As point2d infoarray(64,codenum) '64 = 8 x 8 pixel size
    If runflag=0 Then   '                  'scan codenum of codepage once
        Dim As Uinteger background=0
        Screenres 10,10  '8 x 8 pixels on this screen
        Dim count As Integer
        For ch As Integer=1 To codenum
            Cls
            Draw String(1,1),Chr(ch)
            For x As Integer=1 To 8  'scan for characters
                For y As Integer=1 To 8
                    If Point(x,y)<>background Then
                        count=count+1
                        infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
                    End If 
                Next y
            Next x
            count=0
        Next ch
        runflag=1 
    End If
    If size=0 Then Exit Sub
    Dim As point2d temp(1 To 64,codenum),np
    Dim As Single cr= 0.01745329 'degs to radians
    #macro rotate(p1,p2,a,d)
    np.col=p2.col
    np.x=d*(Cos(a*cr)*(p2.x-p1.x)-Sin(a*cr)*(p2.y-p1.y)) +p1.x
    np.y=d*(Sin(a*cr)*(p2.x-p1.x)+Cos(a*cr)*(p2.y-p1.y)) +p1.y
    #endmacro
    
    Dim As point2d cpt(1 To 64),c=Type<point2d>(xpos,ypos),c2
    Dim As Integer dx=xpos,dy=ypos
    For z6 As Integer=1 To Len(text)
        var asci=text[z6-1]
        If asci=124 Then 
            if charangle<>0 then xpos=xpos+12*sin(charangle*cr)
            dx=xpos:dy=dy+12:Goto skip 'pipe | for new line
        End If
        For _x1 As Integer=1 To 64
            temp(_x1,asci).x=infoarray(_x1,asci).x+dx
            temp(_x1,asci).y=infoarray(_x1,asci).y+dy
            temp(_x1,asci).col=colour
            rotate(c,temp(_x1,asci),textangle,size)
            cpt(_x1)=np
            var copyy=np.y
            If charangle<>0 Then
              if flag then var p=1 else  p=(z6-1)
c2=Type<point2d>(xpos+(size*8)*p*(Cos(textangle*cr)),ypos+(size*8)*p*(Sin(textangle*cr))) 
                rotate(c2,cpt(_x1),charangle,1)
               if flag then np.y=copyy
                cpt(_x1)=np
            End If
            If infoarray(_x1,asci).x<>0 Then 'paint only relevant points 
                If Abs(size)>1 Then
                    line(cpt(_x1).x-size/2,cpt(_x1).y-size/2)-(cpt(_x1).x+size/2,cpt(_x1).y+size/2),cpt(_x1).col,bf
                Else
                    Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).col
                End If
            End If
        Next _x1
        dx=dx+9+4*(sin(charangle*cr))*flag
        skip:
    Next z6 
End Sub
Sub init Constructor 'automatic loader
    drawstring(0,0,"",0,0)
    Screen 0
End Sub


Function framecounter() As Integer
    Var t1=Timer,t2=t1
    Static As Double t3,frames,answer
    frames=frames+1
    If (t2-t3)>=1 Then
        t3=t2
        answer=frames
        frames=0
    End If
    Return answer
End Function

Function regulate(MyFps As Integer,Byref fps As Integer) As Integer
    fps=framecounter
    Static As Double timervalue
    Static As Double delta,lastsleeptime,sleeptime
    Var k=1/myfps
    If Abs(fps-myfps)>1 Then
        If fps<Myfps Then delta=delta-k Else delta=delta+k
    End If
    sleeptime=lastsleeptime+((1/myfps)-(Timer-timervalue))*(2000)+delta
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

#define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)
dim as integer xres,yres
'screen 20,32
screeninfo xres,yres
screenres xres,yres,32,0,1

dim as double pi=4*atn(1)
dim as double rot=7*pi
dim as double inc
dim as integer fps
do
    var sleepytime=regulate(32,fps)
    inc=inc+.1
    screenlock
    cls
    for z as double=inc to rot+inc step rot/250
        var angledegrees=z*180/pi
        var radius=map(inc,(rot+inc),z,30,300)
            
            var xpos1=xres/2+ ((radius+00)*cos(z))
            var ypos1=yres/2+ ((radius+00)*sin(z))
            
            'var xpos2=xres/2+ ((radius+15)*cos(z))
            'var ypos2=yres/2+ ((radius+15)*sin(z))
            
            'var xpos3=xres/2+ ((radius+30)*cos(z))
            'var ypos3=yres/2+ ((radius+30)*sin(z))
        
        var size=map(inc,(rot+inc),z,1.5,3.5)
        var col=map(inc,(rot+inc),z,120,250)
        drawstring xpos1,ypos1 , " * " , rgb( col/2 ,col/2 , 75 ), size, angledegrees,
        drawstring xpos1,ypos1 , "( )" , rgb( col/1.5 ,col/1.5 , 75 ), size, angledegrees,
        if (rot+inc)-z <rot/250 then
         drawstring xpos1,ypos1 , chr(2) , rgb( col/1.5 ,col/1.5 , 75 ),4* size, angledegrees,
         end if
        'drawstring xpos2,ypos2 , "*" , rgb( col/2   ,col/2   , 75 ), size, angledegrees,
        'drawstring xpos3,ypos3 , ")" , rgb( col/1.5 ,col/1.5 , 75 ), size, angledegrees,

    next z
    
    var text = "!!--SNAKEY--!!"
    if int(inc) mod 2 = 0 then drawstring (xres/2)-((len(text)*70)/2),yres/2.5 , text , rgb(200,200,0) , 8 ,0,
    
    drawstring 10,10,"FPS=  " & fps,rgb(0,200,0),2
    screenunlock
    sleep sleepytime,1
loop until len(inkey)

sleep
 
and the 8 X 8 with rotating pixel boxes

Code: Select all


Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour As Uinteger,size As Single,textangle As Single=0,charangle As Single=0,im As Any Pointer=0)
    
    Type point2d
        As Single x,y
        As Uinteger col
    End Type
    Dim As Integer codenum=256           
    Static As Integer runflag
    Static As point2d infoarray()
    Redim Preserve As point2d infoarray(64,codenum) '64 = 8 x 8 pixel size
    If runflag=0 Then   '                  'scan codenum of codepage once
        Dim As Uinteger background=Rgb(0,0,0)
        Screenres 10,10,32  '8 x 8 pixels on this screen
        Dim count As Integer
        For ch As Integer=1 To codenum
            Cls
            Draw String(1,1),Chr(ch)
            For x As Integer=1 To 8  'scan for characters
                For y As Integer=1 To 8
                    If Point(x,y)<>background Then
                        count=count+1
                        infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
                    End If 
                Next y
            Next x
            count=0
        Next ch
        runflag=1 
    End If
    If size=0 Then Exit Sub
    Dim As point2d temp(1 To 64,codenum),np
    Dim As Single cr= 0.01745329,x1,y1,x2,y2 
    #macro rotate(p1,p2,a,d)
    np.col=p2.col
    np.x=d*(Cos(a*cr)*(p2.x-p1.x)-Sin(a*cr)*(p2.y-p1.y)) +p1.x
    np.y=d*(Sin(a*cr)*(p2.x-p1.x)+Cos(a*cr)*(p2.y-p1.y)) +p1.y
    #endmacro
    #macro _box()
    Dim As Single dx=x2-x1,dy=y2-y1
    Swap dx,dy:dx=-dx
    Dim As Single p1x=x1+dx/2,p1y=y1+dy/2
    Dim As Single p2x=x1-dx/2,p2y=y1-dy/2
    Dim As Single p3x=x2+dx/2,p3y=y2+dy/2
    Dim As Single p4x=x2-dx/2,p4y=y2-dy/2
    Dim As Uinteger c=Rgb(255,255,254)
    For x As Integer=1 To 2
        Line im,(p1x,p1y)-(p2x,p2y),c
        Line im,(p3x,p3y)-(p4x,p4y),c
        Line im,(p1x,p1y)-(p3x,p3y),c
        Line im,(p2x,p2y)-(p4x,p4y),c
        Paint im,((p1x+p2x+p3x+p4x)/4,(p1y+p2y+p3y+p4y)/4),c,c
        c=cpt(_x1).col
    Next x
    #endmacro
    Dim As point2d cpt(1 To 64),c=Type<point2d>(xpos,ypos),c2
    Dim As Single sz =size/2
    Dim As Integer dx=xpos,dy=ypos
    start:
    
    For z6 As Integer=1 To Len(text)
        var asci=text[z6-1]
        If asci=124 Then 
            dx=xpos:dy=dy+12:Goto skip
        End If
        c2=Type<point2d>(xpos+(size*(z6-1)*8)*Cos(textangle*cr),ypos+(size*(z6-1)*8)*Sin(textangle*cr))
        For _x1 As Integer=1 To 64
            temp(_x1,asci).x=infoarray(_x1,asci).x+dx
            temp(_x1,asci).y=infoarray(_x1,asci).y+dy
            temp(_x1,asci).col=colour
            rotate(c,temp(_x1,asci),textangle,size)
            cpt(_x1)=np
            If charangle<>0 Then
                rotate(c2,cpt(_x1),charangle,1)
                cpt(_x1)=np
            End If
            x1=cpt(_x1).x-sz*(Cos((textangle+charangle)*cr)):y1=cpt(_x1).y-sz*(Sin((textangle+CHARANGLE)*cr))
            x2=cpt(_x1).x+sz*(Cos((textangle+charangle)*cr)):y2=cpt(_x1).y+sz*(Sin((textangle+charangle)*cr))
            If infoarray(_x1,asci).x<>0 Then 'paint only relevant points 
                
                If Abs(size)>1 Then
                    _box()
                Else
                    Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).col
                End If
            End If
        Next _x1
        dx=dx+9
        skip:
    Next z6 
    
End Sub

Sub init Constructor
    drawstring(0,0,"",0,0)
    Screen 0
End Sub



Function framecounter() As Integer
    Var t1=Timer,t2=t1
    Static As Double t3,frames,answer
    frames=frames+1
    If (t2-t3)>=1 Then
        t3=t2
        answer=frames
        frames=0
    End If
    Return answer
End Function

Function regulate(MyFps As Integer,Byref fps As Integer) As Integer
    fps=framecounter
    Static As Double timervalue
    Static As Double delta,lastsleeptime,sleeptime
    Var k=1/myfps
    If Abs(fps-myfps)>1 Then
        If fps<Myfps Then delta=delta-k Else delta=delta+k
    End If
    sleeptime=lastsleeptime+((1/myfps)-(Timer-timervalue))*(2000)+delta
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

#define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)
dim as integer xres,yres
'screen 20,32
screeninfo xres,yres
screenres xres,yres,32,0,1

dim as double pi=4*atn(1)
dim as double rot=7*pi
dim as double inc
dim as integer fps
do
    var sleepytime=regulate(32,fps)
    inc=inc+.1
    screenlock
    cls
    for z as double=inc to rot+inc step rot/250
        var angledegrees=z*180/pi
        var radius=map(inc,(rot+inc),z,30,300)
            
            var xpos1=xres/2+ ((radius+00)*cos(z))
            var ypos1=yres/2+ ((radius+00)*sin(z))
            
            'var xpos2=xres/2+ ((radius+15)*cos(z))
            'var ypos2=yres/2+ ((radius+15)*sin(z))
            
            'var xpos3=xres/2+ ((radius+30)*cos(z))
            'var ypos3=yres/2+ ((radius+30)*sin(z))
        
        var size=map(inc,(rot+inc),z,1.5,3.5)
        var col=map(inc,(rot+inc),z,120,250)
        drawstring xpos1,ypos1 , " * " , rgb( col/2 ,col/2 , 75 ), size, angledegrees,
        drawstring xpos1,ypos1 , "( )" , rgb( col/1.5 ,col/1.5 , 75 ), size, angledegrees,
        if (rot+inc)-z <rot/250 then
         drawstring xpos1,ypos1 , chr(2) , rgb( col/1.5 ,col/1.5 , 75 ),4* size, angledegrees,
         end if
        'drawstring xpos2,ypos2 , "*" , rgb( col/2   ,col/2   , 75 ), size, angledegrees,
        'drawstring xpos3,ypos3 , ")" , rgb( col/1.5 ,col/1.5 , 75 ), size, angledegrees,

    next z
    
    var text = "!!--SNAKEY--!!"
    if int(inc) mod 2 = 0 then drawstring (xres/2)-((len(text)*70)/2),yres/2.5 , text , rgb(200,200,0) , 8 ,0,
    
    drawstring 10,10,"FPS=  " & fps,rgb(0,200,0),2
    screenunlock
    sleep sleepytime,1
loop until len(inkey)

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

Re: Squares

Post by albert »

@Dodicat

The first one goes the fastest,
Anyway to modify DrawString SUB to do FG , BG character colors, then I can draw the water with it two.

I think the water should be dark blue with lighter waves that alternate..

I think it'll end up looking cheesy , anyway I do it , cause i'm not a good artist.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

Now i'm working on writing a QBASIC like PLAY() statement to make some intro-music..

Code: Select all

'(Pull out beep from lib kernel32.dll and use it.)
Declare Sub Sound Alias "Beep" (Byval frequency As Uinteger, duration As Uinteger)

dim as single note(1 to 12)
note(01) = 16.35
note(02) = 17.32
note(03) = 18.35
note(04) = 19.45
note(05) = 20.60
note(06) = 21.83
note(07) = 23.12
note(08) = 24.50
note(09) = 25.96
note(10) = 27.50
note(11) = 29.14
note(12) = 30.87

dim as string names(1 to 12)
names(01) = "C"
names(02) = "C+ , D-"
names(03) = "D"
names(04) = "D+ , E-"
names(05) = "E"
names(06) = "F"
names(07) = "F+ , G-"
names(08) = "G"
names(09) = "G+ , A-"
names(10) = "A"
names(11) = "A+ , B-"
names(12) = "B"


dim as single freq
for a as ubyte = 1 to 12
    for b as ubyte = 0  to 9
        freq = note(a)*(2^b)
        sound( freq , 500)
        color a
        print names(a) , "Frequency = " ; freq , " Octave = " ; b
    next
    print
    sleep 1000
next

print "DONE."

sleep

I found out theres only 12 notes at octave 0 and then it goes *2 *4 *8 *16 *32 *64 *128 *256 *512 etc..
TJF
Posts: 3809
Joined: Dec 06, 2009 22:27
Location: N47°, E15°
Contact:

Re: Squares

Post by TJF »

albert wrote:Now i'm working on writing a QBASIC like PLAY() statement ...
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@TJF

Its a German site and I don't speak German.

The Roman letter sounds mean the same thing in each of the 57 Romantic languages.
But each language developed their own alphabet and letter grammers based on early life cultures in each country.

Like the "W" and sound of "W" , can mean legs, boobs , fangs , depending on the culture and country , the roman meaning is just "double hang".

Wolf = (W) fangs , (o) mouth, (L) quick, (F) darkness.
Woman = Boobs , circle center , hold point.
Walk = legs , hold , quick , attack.
Water = hang hang , hold top , exit pour = "water fall".


where "N" = up & down = spear = point = convey thought.

During the height of the Roman Catholic church and the inquisitions ,
authors often substituted " F " = darkness for " S " = snake or wave. As the S was seen to be satan the snake and evil to use.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Hi Albert.

I've set the text to opengl.
Just the 8 X 8 version.
I might make up an 8 X 16 version, for it definitely produces better quality, but less speed.
I've used your original method of separating characters with different colours, it is better and you can control the spacing.
Since line thickness in opengl only goes so far (4 I think), thus the text size is limited to about 8 or 9, above that the maximum line thickness is not enough to fill the characters.
However opengl can rotate every pixel along with the textangle and use no extra resources.
I've also included opengl polygon and filled polygon.
With about 60 sides to the polygon circles are produced, so it is easy to do a gl circle or filled circle.
I've set a block behind the text, and set the regulator to 33 fps (which I get).

Code: Select all

 

'old drawstring
#Include "GL/gl.bi"
Sub setup
        Dim As Integer xres,yres
        Screeninfo xres,yres
        glOrtho (0,xres, 0,yres, -1, 1)
        glDisable (GL_DEPTH_TEST)
        glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA)
        glEnable (GL_BLEND)
        glEnable (GL_LINE_SMOOTH)
    End Sub
  #macro Glpolygonfill(x,y,z,rx,ry,numsides,colour)
Scope
    Var pi2 = 8*Atn(1),st=pi2/(numsides)
    glend
    glcolor4f colour
    glBegin GL_TRIANGLE_FAN
    For a As Single=0 To pi2  Step st
        glVertex3f (x)+Cos(a)*(rx),(y)+Sin(a)*(ry),(z)
    Next
    glEnd
End Scope
#endmacro

#macro Glpolygon(x,y,z,rx,ry,numsides,colour)
Scope
    Var pi2 = 8*Atn(1),st=pi2/(numsides)
    glend
    glcolor4f colour
    glBegin GL_LINES
    For a As Single=0 To pi2-st  Step st
        glVertex3f (x)+Cos(a)*(rx),(y)+Sin(a)*(ry),(z)
        glVertex3f (x)+Cos(a+st)*(rx),(y)+Sin(a+st)*(ry),(z)
    Next
    glEnd
End Scope
#endmacro 
Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour() As Double,size As Single,textangle As Single=0,charangle As Single=0,im As Any Pointer=0)
    Dim As Integer wy
    glColor4f (colour(1),colour(2),colour(3),colour(4))
        Screeninfo ,wy
        glend
        glLineWidth(1.1*size)
        glBegin (GL_LINES)
    Type point2d
        As Single x,y
    End Type
    Dim As Integer flag,codenum=256 
    if instr(text,"|") then flag=1
    Static As Integer runflag
    Static As point2d infoarray()
    Redim Preserve As point2d infoarray(64,codenum) '64 = 8 x 8 pixel size
    If runflag=0 Then   '                  'scan codenum of codepage once
        Dim As Uinteger background=0
        Screenres 10,10  '8 x 8 pixels on this screen
        Dim count As Integer
        For ch As Integer=1 To codenum
            Cls
            Draw String(1,1),Chr(ch)
            For x As Integer=1 To 8  'scan for characters
                For y As Integer=1 To 8
                    If Point(x,y)<>background Then
                        count=count+1
                        infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
                    End If 
                Next y
            Next x
            count=0
        Next ch
        runflag=1 
    End If
    If size=0 Then Exit Sub
    Dim As point2d temp(1 To 64,codenum),np
    Dim As Single cr= 0.01745329 'degs to radians
    dim as single d_x=(size/2)*(cos(textangle*cr))
    dim as single d_y=size/2*(sin(textangle*cr))
    #macro rotate(p1,p2,a,d)
    np.x=d*(Cos(a*cr)*(p2.x-p1.x)-Sin(a*cr)*(p2.y-p1.y)) +p1.x
    np.y=d*(Sin(a*cr)*(p2.x-p1.x)+Cos(a*cr)*(p2.y-p1.y)) +p1.y
    #endmacro
    
    Dim As point2d cpt(1 To 64),c=Type<point2d>(xpos,ypos),c2
    Dim As Integer dx=xpos,dy=ypos
    For z6 As Integer=1 To Len(text)
        var asci=text[z6-1]
        If asci=124 Then 
            if charangle<>0 then xpos=xpos+12*sin(charangle*cr)
            dx=xpos:dy=dy+12:Goto skip 'pipe | for new line
        End If
        For _x1 As Integer=1 To 64
            temp(_x1,asci).x=infoarray(_x1,asci).x+dx
            temp(_x1,asci).y=infoarray(_x1,asci).y+dy
            rotate(c,temp(_x1,asci),textangle,size)
            cpt(_x1)=np
            var copyy=np.y
            If charangle<>0 Then
              if flag then var p=1 else  p=(z6-1)
c2=Type<point2d>(xpos+(size*8)*p*(Cos(textangle*cr)),ypos+(size*8)*p*(Sin(textangle*cr))) 
                rotate(c2,cpt(_x1),charangle,1)
               if flag then np.y=copyy
                cpt(_x1)=np
            End If
            If infoarray(_x1,asci).x<>0 Then 'paint only relevant points
                If Abs(size)>0 Then
                        glVertex3f (cpt(_x1).x-d_x,wy-(cpt(_x1).y-d_y),0)
                        glColor4f (colour(1),colour(2),colour(3),colour(4))
                        glVertex3f (cpt(_x1).x+d_x,wy-(cpt(_x1).y+d_y),0)
                    End If
            End If
        Next _x1
        dx=dx+8+4*(sin(charangle*cr))*flag
        skip:
    Next z6 
    glend
End Sub
Sub init Constructor 'automatic loader
    Dim As Double col(1 To 4)
    drawstring(0,0,"",col(),0)
    Screen 0
End Sub


Function framecounter() As Integer
    Var t1=Timer,t2=t1
    Static As Double t3,frames,answer
    frames=frames+1
    If (t2-t3)>=1 Then
        t3=t2
        answer=frames
        frames=0
    End If
    Return answer
End Function

Function regulate(MyFps As Integer,Byref fps As Integer) As Integer
    fps=framecounter
    Static As Double timervalue
    Static As Double delta,lastsleeptime,sleeptime
    Var k=1/myfps
    If Abs(fps-myfps)>1 Then
        If fps<Myfps Then delta=delta-k Else delta=delta+k
    End If
    sleeptime=lastsleeptime+((1/myfps)-(Timer-timervalue))*(2000)+delta
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

sub gltextcolor(a() as double,r as double,g as double,b as double,al as double=255)
    a(1)=r/255:a(2)=g/255:a(3)=b/255:a(4)=al/255
    end sub
#define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)
dim as integer xres,yres

screeninfo xres,yres
Screenres xres,yres,32,,2

setup
dim as double pi=4*atn(1)
dim as double rot=7*pi
dim as double inc
dim as integer fps
dim as double c(1 to 4)
do
    var sleepytime=regulate(33,fps)
    inc=inc+.1
    glClear (GL_COLOR_BUFFER_BIT)
    'example for fast fillcircle and circle
 glpolygonfill(.1*xres,.9*yres,0,40,40,60,(1,0,1,1))
 glpolygon(.1*xres,.7*yres,0,40,40,60,(0,1,1,1))
 
    for z as double=inc to rot+inc step rot/250
        var angledegrees=z*180/pi
        var radius=map(inc,(rot+inc),z,30,300)
            
            var xpos1=xres/2+ ((radius+00)*cos(z))
            var ypos1=yres/2+ ((radius+00)*sin(z))
            
            var xpos2=xres/2+ ((radius+20)*cos(z))
            var ypos2=yres/2+ ((radius+20)*sin(z))
            
            var xpos3=xres/2+ ((radius+45)*cos(z))
            var ypos3=yres/2+ ((radius+45)*sin(z))
        
        var size=map(inc,(rot+inc),z,1.5,3.5)
        var col=map(inc,(rot+inc),z,120,250)
        'my method
        ''gltextcolor c(),col/2,col/2,75
        ''drawstring xpos1,ypos1 , " * " , c(), size, angledegrees,
        ''gltextcolor c(),col/1.5,col/1.5,75
       '' drawstring xpos1,ypos1 , "( )" , c(), size, angledegrees,
       'Albert's method
         gltextcolor c(),col/1.5,col/1.5,75
         drawstring xpos1,ypos1 , "(" , c(), size, angledegrees,
         gltextcolor c(),col/2,col/2,75
        drawstring xpos2,ypos2 , "*" , c(), size, angledegrees,
        gltextcolor c(),col/1.5,col/1.5,75
        drawstring xpos3,ypos3 , ")" , c(), size, angledegrees,
       
        if (rot+inc)-z <rot/250 then
         drawstring xpos1,ypos1 , chr(2) ,c(),2.5* size, angledegrees,
        end if
         

    next z
    
    var text = "!!--SNAKEY--!!"
    if int(inc) mod 2 = 0 then 
        gltextcolor c(),100,0,100
        drawstring  (xres/2)-((len(text)*70)/2) ,yres/2.5-6,string(len(text)-1,chr(219)),c(),8.5  
        gltextcolor c(),200,200,0
        drawstring (xres/2)-((len(text)*70)/2),yres/2.5 , text , c() , 8 ,0,
        end if
    gltextcolor c(),0,200,0
    drawstring 10,10,"FPS=  " & fps,c(),2
    flip
    sleep sleepytime,1
loop until len(inkey)
 
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

Is that all OpenGL ?? its fast, doing 30 to 34 FPS , faster than the original which was doing 23.

I had put it aside to work on , intro-music , trying to get some interesting sounds that don't interrupt the program.

In the end program, the snake has to start small and grow longer with each food pellet it eats, and then after eating all the pellets on a level it will probably go into a whirlpool and come out in the next level...

I was gong to allow the snake to overlap itself or tie its self in knots as long as in keeps going forward.
In the QBASIC NIBBLES.BAS the snake died if it touched itself or a wall of the level.

'=================================================================================================
OFF TOPIC
I was doing geneology research and looked in Scottlands govt. website for Scottish Heraldry and couldn't find any Highlander names
I looked under English Heraldry and found the different family crests. Are the Highlands not part of Scottland ?? or are they British owned ??
I read on the internet that Scottland is mulling around the idea of separating from Britton and might do so by 2014. That might affect the Royal family since Prince Charles and his father are Scottish..
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

I can't run nibbles.bas on quickbasic for some reason.
It starts ok but reports a division by zero.
I've tried to fudge the code a bit but then I see only the screen with a life lost each time I press space.

TJF was trying to be helpful with PLAY.
I don't use the German site much, only to download the latest fb with all the -gen c stuff in place.

You can use opengl easily enough just using the ortho screen for simple graphics.
Point and line are of course already in gl, the circle I added to the previous code snippet so it would be handy enough, and drawstring is also handy enough.

Off topic
The Highlands are the North Western part of Scotland.
Many of the old Clan names are Mac something.
Great Britain (United Kingdom) is basically four countries and a few independent Islands.
That is Scotland,England, Northern Ireland and Wales, Isle of man, Channel Islands.
Southern Ireland left the Union in the Twenties and is now independent.
Scotland and England united basically for financial reasons, the Panama canal project had much to do with it.
Scotland will more than likely return to it's independent state in 2014.
If it Wasn't for world war 1 Scotland would have left the union about the same time Southern Ireland did, then World War 2 interrupted things again.

Our Royal line were the Stuarts, of French origin. Scotland historically always had an alliance with France. Queen Elizabeth 1st of England was party to executing Scotland's Queen, Mary Queen of Scots, a Stuart.
This is why in Scotland we refer to the present Queen as just Queen Elizabeth, not Queen Elizabeth 2nd.

When France conquered England, the Norman conquest ~1066, they didn't enter Scotland, for we were allied anyway.
No one has ever conquered Scotland within living memory, so we have been a very stable country throughout history.

Within the next few years the four countries of the United Kingdom will all probably revert to their original independent status, independent in as much as how can a country be independent these days?
But at least they will revert to their own parliaments.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

I clinked on TJF's link, and it went to a website in written in German,
I couldn't figure out which button to click to download the example,
I Had similar problems with some Russian and Oriental websites.

Seems knowing the meaning of Latin letters, isn't enough as some countries have different cultures to apply..
Like LO = long circle , PO = lift circle , BO = pulldown circle , all mean pole in different countries.

The G originally meant growth, a seed sprout curled up , but since poop grows out of you, people began using G for poop , so the Romans added a small g to denote poop to be separate from growth, so now G means growth and g means movement or poop. But in English you only use capitals at the beginning of a sentence or proper noun, which isn't proper in Latin.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@TJF

Thanks for the link to the PLAY command, I finally found which button to click to download it..
It works as QBASIC PLAY does, thanks..
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Hi Albert.
I've modified my divider to include mod as an option.

Code: Select all

 

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
Endif
#endmacro
insert(answer,".",decpos)
  answer=thepoint+zeros+answer
If dpflag="raw" Then
    answer=Mid(answer,1,decimal_places)
    Endif
#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
    Endif
    #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
    Endif
If Instr(divisor,".") Then 
    Removepoint(divisor)
    divisor=var1+var2
    Endif
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
        Dim As String one,two
       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 Not lens<lenf Then 
If Lens>lenf Then
temp= "done"
Exit Do
Endif
If divisor>topstring Then 
temp= "done"
Exit Do
Endif
Endif

  diff=lenf-lens-Sgn(lenf-lens)
        temp=topstring
        two=String(lenf-lens,"0")+divisor
        one=topstring
        subtractcarry=0
        
        For n3=lenf-1 To diff Step -1
            takeaway= one[n3]-two[n3]+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= one[n3]-two[n3]+10-subtractcarry
             temp[n3]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            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
           Endif
   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
'===================  END DIVIDE ==============================

#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#macro make(s)
    s=string(10000," ")
for n as integer=0 to len(s)-1
    s[n]=intrange(48,57)
next n
#endmacro

'test
dim as string ans
dim as string mod1,mod2
for z as integer=1 to 50000
    mod1=str(IntRange(1,200000))
    mod2=str(IntRange(1,200000))
ans=divide(mod1,mod2,0,"mod")

if valint(ans)<>valint(mod1) mod valint(mod2) then
    print mod1,mod2
 print ans,valint(mod1) mod valint(mod2)
end if

next z
print "End comparison test, press a key"

sleep
dim as string numerator,denominator

make(numerator)
make(denominator)
dim as string answer,modanswer

answer=divide(numerator,denominator,10000)
print "numerator/denominator ="
print answer

print "length numerator   ";len(numerator)
print "length denominator ";len(denominator)
print "Length of answer   ";len(answer)
print "Press a key for mod"
sleep
modanswer=divide(numerator,denominator,0,"mod")
print "numerator mod denominator = ";modanswer
print "Length of mod ";len(modanswer)
print "END"
sleep



 
Locked