Coding Challenge

For other topics related to the FreeBASIC project or its community.
fatman2021
Posts: 135
Joined: Dec 14, 2013 0:43

Coding Challenge

Postby fatman2021 » Aug 27, 2017 15:50

Display a Window Bitmap on a 3D plane:

Must be pure FreeBASIC(No OpenGL, assembly, etc. allowed)
Must support 3D rotation and zoom.
Must compile and run under DOS.

Can not be restricted to any one graphics mode.
badidea
Posts: 1545
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Coding Challenge

Postby badidea » Sep 03, 2017 14:32

Is there a prize to win?
grindstone
Posts: 650
Joined: May 05, 2015 5:35
Location: Germany

Re: Coding Challenge

Postby grindstone » Sep 03, 2017 22:24

Is there a prize to win?
Aren't we all in here only just for fun?
MrSwiss
Posts: 3262
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: Coding Challenge

Postby MrSwiss » Sep 03, 2017 22:32

fatman2021 wrote:Must compile and run under DOS.
grindstone wrote:Aren't we all in here only just for fun?
Well, I'd say: DOS isn't any fun (I'm not interested, in catering for dinosaur OS's)!
angros47
Posts: 1514
Joined: Jun 21, 2005 19:04

Re: Coding Challenge

Postby angros47 » Sep 03, 2017 22:47

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

Re: Coding Challenge

Postby dodicat » Sep 04, 2017 15:01

Maybe something like:

Code: Select all



dim as string bmpfile="bird.bmp"
#include "file.bi"
'<><><><><><><><><><><> Quick SORT <><><><><><><><><><>
#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
    Sub fname(array() As datatype,begin As Long,Finish As Ulong)
    Dim As Long i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
        While array(I)dot b1 X dot:I+=1:Wend
        While array(J)dot b2 X dot:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
    Wend
    If J > begin Then fname(array(),begin,J)
    If I < Finish Then fname(array(),I,Finish)
    End Sub
#endmacro     
'<><><><><><><><><><><><><><><><><><><><><><>

screen 20,32
dim shared as integer bts
screeninfo ,,bts
dim as any ptr i=imagecreate(200,200,rgb(0,200,0))
sub GetSize(bmp As String,byref dx as long,byref dy as long,byref b as ushort=0) 'get bitmap width/height/ colour resolution
   ' print bmp
    Open bmp For Binary access read As #1
    Get #1, 19, dX
    Get #1, 23, dY
    get #1, 29, b
    Close #1
End sub

function mapS(a as single,b as single,x as single,c as single,d as single) as single
    return ((d)-(c))*((x)-(a))/((b)-(a))+(c)
end function

function resize(picture As String,_x As Integer,_y As Integer) as any ptr
    dim as long dimensionx,dimensiony
    Getsize(picture,dimensionx,dimensiony)
    Dim Scale_x As Double=_x/dimensionx
    Dim Scale_y As Double=_y/dimensiony
    var dx=_x/dimensionx,dy=_y/dimensiony
    dim as any ptr im=Imagecreate(dimensionx,dimensiony)
    dim as any ptr tim=Imagecreate(_x,_y)
            Bload picture,im
            Dim As Ulong col
            For y As Integer=0 To (dimensiony-1)
                For x As Integer=0 To (dimensionx-1)
                    Dim As Integer xx=mapS(0,dimensionx,x,0,_x)
                    Dim As Integer yy=mapS(0,dimensiony,y,0,_y)
                   Line tim,(xx-dx,yy-dy)-(xx+dx,yy+dy),point(x,y,im),bf
                Next x
            Next y
        return tim
End function

Type Point 'VECTOR POINT
    As double x,y,z
    As Ulong col
    as byte flag
End Type:SetQsort(point,QsortZ,down,.z) 'set up the quicksort

type sincos 'FLOATS for angles
    as single sx,sy,sz
    as single cx,cy,cz
    declare static function construct(as single,as single,as single) as sincos
end type



#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#macro incircle(cx,cy,radius,x,y)

(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro

function sincos.construct(x as single,y as single,z as single) as sincos
    return   type <sincos>(sin(x),sin(y),sin(z), _
                           cos(x),cos(y),cos(z))
   end function
   
Function RotatePoint(c As Point,p As Point,a as sincos,scale As sincos=Type<sincos>(1,1,1)) As Point
    Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
    Return Type<Point>((scale.sx)*((a.cy*a.cz)*dx+(-a.cx*a.sz+a.sx*a.sy*a.cz)*dy+(a.sx*a.sz+a.cx*a.sy*a.cz)*dz)+c.x,_
    (scale.sy)*((a.cy*a.sz)*dx+(a.cx*a.cz+a.sx*a.sy*a.sz)*dy+(-a.sx*a.cz+a.cx*a.sy*a.sz)*dz)+c.y,_
    (scale.sz)*((-a.sy)*dx+(a.sx*a.cy)*dy+(a.cx*a.cy)*dz)+c.z,p.col,p.flag)
End Function

Function perspective(p As Point,eyepoint As Point) As Point
    Dim As Single   w=1+(p.z/eyepoint.z)
    Return Type<Point>((p.x-eyepoint.x)/w+eyepoint.x,(p.y-eyepoint.y)/w+eyepoint.y,(p.z-eyepoint.z)/w+eyepoint.z,p.col,p.flag)
End Function

function contrast(c as ulong) as ulong 'make one random colour over another different
       dim as ubyte r=Cptr(Ubyte Ptr,@c)[2],g=Cptr(Ubyte Ptr,@c)[1],b=Cptr(Ubyte Ptr,@c)[0],r2,g2,b2
       do
           r2=Intrange(0,255):g2=IntRange(0,255):b2=IntRange(0,255)
           loop until abs(r-r2)>120 andalso abs(g-g2)>120 andalso abs(b-b2)>120
          return rgb(r2,g2,b2)
   end function
   
  Sub _line(x1 As long,y1 As long,x2 As long,y2 As long,l As long,col As Ulong,byref xp as long=0,byref yp as long=0)
    Dim As long diffx=x2-x1,diffy=y2-y1,ln=Sqr(diffx*diffx+diffy*diffy)
    if ln=0 then ln=1e-6
    Dim As Single nx=diffx/ln,ny=diffy/ln
    xp=x1+l*nx:yp=y1+l*ny
        Line(x1,y1)-(xp,yp),col
End Sub

sub mouse(mx as long,my as long,sz as long)
    dim as long xp,yp
    _line(mx,my,mx+sz,my+.8*sz,sz,rgb(50,50,50),xp,yp)
    _line(xp,yp,mx+sz/2,yp+.03*sz,.4*sz,rgb(50,50,50),xp,yp)
    var tx=xp,ty=yp
    _line(mx,my,mx,my+1.2*sz,sz,rgb(50,50,50),xp,yp)
    _line(xp,yp,mx+sz/2,yp-sz/2,.4*sz,rgb(50,50,50),xp,yp)
    _line(xp,yp,mx+sz/2,yp+sz/2,sz,rgb(50,50,50),xp,yp)
    _line(xp,yp,xp+sz/2,yp-.4*sz,.2*sz,rgb(50,50,50),xp,yp)
    _line(xp,yp,tx,ty,.95*sz,rgb(50,50,50),xp,yp)
    paint(mx+.1*sz,my+.2*sz),rgb(200,200,200),rgb(50,50,50)
end sub

function shade(c as ulong,n as single) as ulong
   if bts<16 then  return c
   if n>1 or n<0 then exit function
return rgba(Cptr(Ubyte Ptr,@c)[2]*n,Cptr(Ubyte Ptr,@c)[1]*n,Cptr(Ubyte Ptr,@c)[0]*n,Cptr(Ubyte Ptr,@c)[3])
end function

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
            Static As Double timervalue,_lastsleeptime,t3,frames
            var t=Timer
            frames+=1
            If (t-t3)>=1 Then t3=t:fps=frames:frames=0
            Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
            If sleeptime<1 Then sleeptime=1
            _lastsleeptime=sleeptime
            timervalue=T
            Return sleeptime
        End Function
       
#macro anotherplate()
a2=sincos.construct(-pi/2,0,0)
ub=ubound(a)
for n as long=lbound(a) to ubound(a)/2
    var tmp=rotatepoint(type<point>(cx,cy),a(n),a2)
    redim preserve a(ub+n)
    a(ub+n)=tmp
next n
#endmacro

'============================ set up the plates =======================
dim as long Pflag
'dim as string bmpfile="bob.bmp"
start:
randomize 3
#define IR IntRange(0,3)

if fileexists (bmpfile) then
    i=resize(bmpfile,200,200)
    else
print bmpfile; " not found, loading some numbers instead"
for x as long=0 to 200 step 20
    for y as long=0 to 200 step 20
        dim as ulong col=rgb(rnd*255,rnd*255,rnd*255)
        line i,(x,y)-(x+20,y+20),col,bf
        draw string i,(x+8,y+4),chr(IntRange(48,57)),contrast(col)
next:next
end if

'capture the image in an array
redim as point a()

dim as long ctr,cx,cy
for x as long=0 to 199
    for y as long=0 to 199
        ctr+=1
        redim preserve a(1 to ctr)
        a(ctr)=type(x,y,0,point(x,y,i),IR)
        cx+=x:cy+=y
    next
next
cx=cx/ctr:cy=cy/ctr'centre of plate
'Rotate the plate 90 degrees on y axis and add to the first plate
ctr=0

var ub=ubound(a)+1
dim as single pi=4*atn(1)


var a2=sincos.construct(0,-pi/2,0)
for n as long=lbound(a) to ubound(a)
    var tmp=rotatepoint(type<point>(cx,cy),a(n),a2)
    redim preserve a(ub+n)
    a(ub+n)=tmp
next n

a2=sincos.construct(0,0,0)

'
dim as single sz=1.5
for n as long=lbound(a) to ubound(a)
    a(n)=rotatepoint(Type<Point>(cx,cy,0),a(n),a2,type<sincos>(sz,sz,sz))
    a(n).x+=400:a(n).y+=300
next n
cx+=400:cy+=300
'==================================

'=============================================================================
if Pflag then : anotherplate() :end if ''if your cpu is fast

redim as point rot(lbound(a) to ubound(a))

dim as single cm,cs
dim as long fps,finish
dim as string k
'sz=1
dim as sincos Mag
dim as single anglex,angley,anglez,minz,maxz,eye=800
dim as integer mx,my,mb,flag,kp=1
Do
    maxz=1e-10
    minz=1e10
     Mag=type<sincos>(sz,sz,sz)'the scaler
    getmouse mx,my,,mb
    anglex-=.025:if anglex>2*pi then anglex=0
    angley-=.015:if angley>2*pi then anglez=0
    anglez-=.012:if anglez>2*pi then anglex=0
    k=inkey
    if k=chr(27) and finish=0 then finish=1
    if finish then
        Pflag=0
        sz=2
        cm+=150
        for n as long=lbound(a) to ubound(a)
            a(n).z+=IntRange(140,160)
            select case as const a(n).flag
            case 0:a(n).x+=IntRange(5,15)\4
            case 1:a(n).y+=IntRange(5,15)\4
            case 2:a(n).x-=IntRange(5,15)\4
            case 3:a(n).y-=IntRange(5,15)\4
            end select
        next n
    end if
   
   var SC=sincos.construct(anglex,angley,anglez)
        eye=100+700*sz
    For n As long=Lbound(a) To Ubound(a)
         rot(n) =rotatepoint(Type<Point>(cx,cy,cm),a(n),SC,mag)
         rot(n) =perspective(rot(n),Type<Point>(cx,cy,eye))
         if maxz<rot(n).z then maxz=rot(n).z
         if minz>rot(n).z then minz=rot(n).z
    Next n
     
    Qsortz(rot(),Lbound(rot),Ubound(rot))
   
     Screenlock
    Cls
   
     For n As long=Lbound(a) To Ubound(a)
        dim as single rad=map(maxz,minz,rot(n).z,1,2.75)
        dim as single s=map(maxz,minz,rot(n).z,.1,1) '
        if finish=0 then
        circle(rot(n).x,rot(n).y),rad*sz,shade(rot(n).col,s),,,,f
        else
        pset(rot(n).x,rot(n).y),(rot(n).col)
        end if
    Next n
    Draw String(10,10), "Number of points " & Ubound(a),Rgb(200,0,0)
    Draw String(10,50), "Framerate " & fps
    draw string(10,300),"bigger"
    mouse(60,310,25)
    draw string(10,400),"smaller"
    mouse(68,410,25)
   
    if pflag=0 and finish=0 then
    draw string(5,490),"One more plate,(only for fast machine)"
     mouse(68,510,25)
    if incircle(60,510,50,mx,my) and flag=0 and mb=1 and finish=0 then
    flag=1:Pflag=1:kp=1
    screenunlock
    exit do
    'anotherplate()
end if
end if

 if pflag=1 and finish=0 then
    draw string(5,490),"Two plates only"
     mouse(68,510,25)
    if incircle(60,510,50,mx,my) and flag=0 and mb=1 and finish=0 then
    flag=1:Pflag=1:kp=0
    screenunlock
    exit do
    'anotherplate() gone
end if
end if

    Screenunlock
    if incircle(60,310,50,mx,my) and flag=0 and mb=1 and finish=0 then flag=1:sz*=1.1 '.01
    if incircle(60,410,50,mx,my) and flag=0 and mb=1 and finish=0 then flag=1:sz*=.9
    sleep regulate(20,fps),1
    flag=mb
Loop Until cm>10000
if pflag then pflag*=kp: goto start
cls
draw string(400,300), "DONE"
sleep
screen 0
imagedestroy i

         

         

If the bitmap (top line) is not found, not to worry, you get some numbers.
fatman2021
Posts: 135
Joined: Dec 14, 2013 0:43

Re: Coding Challenge

Postby fatman2021 » Sep 08, 2017 21:05

dodicat wrote:Maybe something like:

Code: Select all



dim as string bmpfile="bird.bmp"
#include "file.bi"
'<><><><><><><><><><><> Quick SORT <><><><><><><><><><>
#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
    Sub fname(array() As datatype,begin As Long,Finish As Ulong)
    Dim As Long i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
        While array(I)dot b1 X dot:I+=1:Wend
        While array(J)dot b2 X dot:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
    Wend
    If J > begin Then fname(array(),begin,J)
    If I < Finish Then fname(array(),I,Finish)
    End Sub
#endmacro     
'<><><><><><><><><><><><><><><><><><><><><><>

screen 20,32
dim shared as integer bts
screeninfo ,,bts
dim as any ptr i=imagecreate(200,200,rgb(0,200,0))
sub GetSize(bmp As String,byref dx as long,byref dy as long,byref b as ushort=0) 'get bitmap width/height/ colour resolution
   ' print bmp
    Open bmp For Binary access read As #1
    Get #1, 19, dX
    Get #1, 23, dY
    get #1, 29, b
    Close #1
End sub

function mapS(a as single,b as single,x as single,c as single,d as single) as single
    return ((d)-(c))*((x)-(a))/((b)-(a))+(c)
end function

function resize(picture As String,_x As Integer,_y As Integer) as any ptr
    dim as long dimensionx,dimensiony
    Getsize(picture,dimensionx,dimensiony)
    Dim Scale_x As Double=_x/dimensionx
    Dim Scale_y As Double=_y/dimensiony
    var dx=_x/dimensionx,dy=_y/dimensiony
    dim as any ptr im=Imagecreate(dimensionx,dimensiony)
    dim as any ptr tim=Imagecreate(_x,_y)
            Bload picture,im
            Dim As Ulong col
            For y As Integer=0 To (dimensiony-1)
                For x As Integer=0 To (dimensionx-1)
                    Dim As Integer xx=mapS(0,dimensionx,x,0,_x)
                    Dim As Integer yy=mapS(0,dimensiony,y,0,_y)
                   Line tim,(xx-dx,yy-dy)-(xx+dx,yy+dy),point(x,y,im),bf
                Next x
            Next y
        return tim
End function

Type Point 'VECTOR POINT
    As double x,y,z
    As Ulong col
    as byte flag
End Type:SetQsort(point,QsortZ,down,.z) 'set up the quicksort

type sincos 'FLOATS for angles
    as single sx,sy,sz
    as single cx,cy,cz
    declare static function construct(as single,as single,as single) as sincos
end type



#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#macro incircle(cx,cy,radius,x,y)

(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro

function sincos.construct(x as single,y as single,z as single) as sincos
    return   type <sincos>(sin(x),sin(y),sin(z), _
                           cos(x),cos(y),cos(z))
   end function
   
Function RotatePoint(c As Point,p As Point,a as sincos,scale As sincos=Type<sincos>(1,1,1)) As Point
    Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
    Return Type<Point>((scale.sx)*((a.cy*a.cz)*dx+(-a.cx*a.sz+a.sx*a.sy*a.cz)*dy+(a.sx*a.sz+a.cx*a.sy*a.cz)*dz)+c.x,_
    (scale.sy)*((a.cy*a.sz)*dx+(a.cx*a.cz+a.sx*a.sy*a.sz)*dy+(-a.sx*a.cz+a.cx*a.sy*a.sz)*dz)+c.y,_
    (scale.sz)*((-a.sy)*dx+(a.sx*a.cy)*dy+(a.cx*a.cy)*dz)+c.z,p.col,p.flag)
End Function

Function perspective(p As Point,eyepoint As Point) As Point
    Dim As Single   w=1+(p.z/eyepoint.z)
    Return Type<Point>((p.x-eyepoint.x)/w+eyepoint.x,(p.y-eyepoint.y)/w+eyepoint.y,(p.z-eyepoint.z)/w+eyepoint.z,p.col,p.flag)
End Function

function contrast(c as ulong) as ulong 'make one random colour over another different
       dim as ubyte r=Cptr(Ubyte Ptr,@c)[2],g=Cptr(Ubyte Ptr,@c)[1],b=Cptr(Ubyte Ptr,@c)[0],r2,g2,b2
       do
           r2=Intrange(0,255):g2=IntRange(0,255):b2=IntRange(0,255)
           loop until abs(r-r2)>120 andalso abs(g-g2)>120 andalso abs(b-b2)>120
          return rgb(r2,g2,b2)
   end function
   
  Sub _line(x1 As long,y1 As long,x2 As long,y2 As long,l As long,col As Ulong,byref xp as long=0,byref yp as long=0)
    Dim As long diffx=x2-x1,diffy=y2-y1,ln=Sqr(diffx*diffx+diffy*diffy)
    if ln=0 then ln=1e-6
    Dim As Single nx=diffx/ln,ny=diffy/ln
    xp=x1+l*nx:yp=y1+l*ny
        Line(x1,y1)-(xp,yp),col
End Sub

sub mouse(mx as long,my as long,sz as long)
    dim as long xp,yp
    _line(mx,my,mx+sz,my+.8*sz,sz,rgb(50,50,50),xp,yp)
    _line(xp,yp,mx+sz/2,yp+.03*sz,.4*sz,rgb(50,50,50),xp,yp)
    var tx=xp,ty=yp
    _line(mx,my,mx,my+1.2*sz,sz,rgb(50,50,50),xp,yp)
    _line(xp,yp,mx+sz/2,yp-sz/2,.4*sz,rgb(50,50,50),xp,yp)
    _line(xp,yp,mx+sz/2,yp+sz/2,sz,rgb(50,50,50),xp,yp)
    _line(xp,yp,xp+sz/2,yp-.4*sz,.2*sz,rgb(50,50,50),xp,yp)
    _line(xp,yp,tx,ty,.95*sz,rgb(50,50,50),xp,yp)
    paint(mx+.1*sz,my+.2*sz),rgb(200,200,200),rgb(50,50,50)
end sub

function shade(c as ulong,n as single) as ulong
   if bts<16 then  return c
   if n>1 or n<0 then exit function
return rgba(Cptr(Ubyte Ptr,@c)[2]*n,Cptr(Ubyte Ptr,@c)[1]*n,Cptr(Ubyte Ptr,@c)[0]*n,Cptr(Ubyte Ptr,@c)[3])
end function

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
            Static As Double timervalue,_lastsleeptime,t3,frames
            var t=Timer
            frames+=1
            If (t-t3)>=1 Then t3=t:fps=frames:frames=0
            Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
            If sleeptime<1 Then sleeptime=1
            _lastsleeptime=sleeptime
            timervalue=T
            Return sleeptime
        End Function
       
#macro anotherplate()
a2=sincos.construct(-pi/2,0,0)
ub=ubound(a)
for n as long=lbound(a) to ubound(a)/2
    var tmp=rotatepoint(type<point>(cx,cy),a(n),a2)
    redim preserve a(ub+n)
    a(ub+n)=tmp
next n
#endmacro

'============================ set up the plates =======================
dim as long Pflag
'dim as string bmpfile="bob.bmp"
start:
randomize 3
#define IR IntRange(0,3)

if fileexists (bmpfile) then
    i=resize(bmpfile,200,200)
    else
print bmpfile; " not found, loading some numbers instead"
for x as long=0 to 200 step 20
    for y as long=0 to 200 step 20
        dim as ulong col=rgb(rnd*255,rnd*255,rnd*255)
        line i,(x,y)-(x+20,y+20),col,bf
        draw string i,(x+8,y+4),chr(IntRange(48,57)),contrast(col)
next:next
end if

'capture the image in an array
redim as point a()

dim as long ctr,cx,cy
for x as long=0 to 199
    for y as long=0 to 199
        ctr+=1
        redim preserve a(1 to ctr)
        a(ctr)=type(x,y,0,point(x,y,i),IR)
        cx+=x:cy+=y
    next
next
cx=cx/ctr:cy=cy/ctr'centre of plate
'Rotate the plate 90 degrees on y axis and add to the first plate
ctr=0

var ub=ubound(a)+1
dim as single pi=4*atn(1)


var a2=sincos.construct(0,-pi/2,0)
for n as long=lbound(a) to ubound(a)
    var tmp=rotatepoint(type<point>(cx,cy),a(n),a2)
    redim preserve a(ub+n)
    a(ub+n)=tmp
next n

a2=sincos.construct(0,0,0)

'
dim as single sz=1.5
for n as long=lbound(a) to ubound(a)
    a(n)=rotatepoint(Type<Point>(cx,cy,0),a(n),a2,type<sincos>(sz,sz,sz))
    a(n).x+=400:a(n).y+=300
next n
cx+=400:cy+=300
'==================================

'=============================================================================
if Pflag then : anotherplate() :end if ''if your cpu is fast

redim as point rot(lbound(a) to ubound(a))

dim as single cm,cs
dim as long fps,finish
dim as string k
'sz=1
dim as sincos Mag
dim as single anglex,angley,anglez,minz,maxz,eye=800
dim as integer mx,my,mb,flag,kp=1
Do
    maxz=1e-10
    minz=1e10
     Mag=type<sincos>(sz,sz,sz)'the scaler
    getmouse mx,my,,mb
    anglex-=.025:if anglex>2*pi then anglex=0
    angley-=.015:if angley>2*pi then anglez=0
    anglez-=.012:if anglez>2*pi then anglex=0
    k=inkey
    if k=chr(27) and finish=0 then finish=1
    if finish then
        Pflag=0
        sz=2
        cm+=150
        for n as long=lbound(a) to ubound(a)
            a(n).z+=IntRange(140,160)
            select case as const a(n).flag
            case 0:a(n).x+=IntRange(5,15)\4
            case 1:a(n).y+=IntRange(5,15)\4
            case 2:a(n).x-=IntRange(5,15)\4
            case 3:a(n).y-=IntRange(5,15)\4
            end select
        next n
    end if
   
   var SC=sincos.construct(anglex,angley,anglez)
        eye=100+700*sz
    For n As long=Lbound(a) To Ubound(a)
         rot(n) =rotatepoint(Type<Point>(cx,cy,cm),a(n),SC,mag)
         rot(n) =perspective(rot(n),Type<Point>(cx,cy,eye))
         if maxz<rot(n).z then maxz=rot(n).z
         if minz>rot(n).z then minz=rot(n).z
    Next n
     
    Qsortz(rot(),Lbound(rot),Ubound(rot))
   
     Screenlock
    Cls
   
     For n As long=Lbound(a) To Ubound(a)
        dim as single rad=map(maxz,minz,rot(n).z,1,2.75)
        dim as single s=map(maxz,minz,rot(n).z,.1,1) '
        if finish=0 then
        circle(rot(n).x,rot(n).y),rad*sz,shade(rot(n).col,s),,,,f
        else
        pset(rot(n).x,rot(n).y),(rot(n).col)
        end if
    Next n
    Draw String(10,10), "Number of points " & Ubound(a),Rgb(200,0,0)
    Draw String(10,50), "Framerate " & fps
    draw string(10,300),"bigger"
    mouse(60,310,25)
    draw string(10,400),"smaller"
    mouse(68,410,25)
   
    if pflag=0 and finish=0 then
    draw string(5,490),"One more plate,(only for fast machine)"
     mouse(68,510,25)
    if incircle(60,510,50,mx,my) and flag=0 and mb=1 and finish=0 then
    flag=1:Pflag=1:kp=1
    screenunlock
    exit do
    'anotherplate()
end if
end if

 if pflag=1 and finish=0 then
    draw string(5,490),"Two plates only"
     mouse(68,510,25)
    if incircle(60,510,50,mx,my) and flag=0 and mb=1 and finish=0 then
    flag=1:Pflag=1:kp=0
    screenunlock
    exit do
    'anotherplate() gone
end if
end if

    Screenunlock
    if incircle(60,310,50,mx,my) and flag=0 and mb=1 and finish=0 then flag=1:sz*=1.1 '.01
    if incircle(60,410,50,mx,my) and flag=0 and mb=1 and finish=0 then flag=1:sz*=.9
    sleep regulate(20,fps),1
    flag=mb
Loop Until cm>10000
if pflag then pflag*=kp: goto start
cls
draw string(400,300), "DONE"
sleep
screen 0
imagedestroy i

         

         

If the bitmap (top line) is not found, not to worry, you get some numbers.


Good Work..

Return to “Community Discussion”

Who is online

Users browsing this forum: MSN [Bot] and 4 guests