Code: Select all
'============= FONTS SET UP ==========================
Function Filter(Byref tim As Ulong Pointer,_
rad As Single,_
destroy as long=1,_
fade as long=0) As Ulong Pointer
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
if fade<0 then fade=0:if fade>100 then fade=100
Type p2
As long x,y
As Ulong col
End Type
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
(colour)=*pixel
#endmacro
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
*pixel=(colour)
#endmacro
#macro average()
ar=0:ag=0:ab=0:inc=0
xmin=x:If xmin>rad Then xmin=rad
xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
ymin=y:If ymin>rad Then ymin=rad
ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
For y1 As long=-ymin To ymax
For x1 As long=-xmin To xmax
inc=inc+1
ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
ab=ab+(NewPoints(x+x1,y+y1).col And 255)
Next x1
Next y1
if fade=0 then
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
else
averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
end if
#endmacro
dim as single fd=map(0,100,fade,1,0)
Dim As long _x,_y
Imageinfo tim,_x,_y
Dim As Ulong Pointer im=Imagecreate(_x,_y)
Dim As long pitch
Dim As Any Pointer row
Dim As Ulong Pointer pixel
Dim As Ulong col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x-1,_y-1)
For y As long=0 To (_y)-1
For x As long=0 To (_x)-1
ppoint(x,y,col)
NewPoints(x,y)=type<p2>(x,y,col)
Next x
Next y
Dim As Ulong averagecolour
Dim As long ar,ag,ab
Dim As long xmin,xmax,ymin,ymax,inc
Imageinfo im,,,,pitch,row
For y As long=0 To _y-1
For x As long=0 To _x-1
average()
ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour)
Next x
Next y
if destroy then ImageDestroy tim: tim = 0
Function= im
End Function
'basic dos fonts
Sub drawstring(xpos As long,ypos As long,text As String,colour As Ulong,size As Single,im As Any Pointer=0)
Type D2
As Double x,y
As Ulong col
End Type
Static As d2 cpt(),XY()
Static As long runflag
If runflag=0 Then
Redim XY(128,127)
Redim cpt(1 To 64*2)
screen 12
dim as ulong pointer img
Dim count As long
For ch As long=1 To 127
img=imagecreate(640,200)
Draw String img,(1,1),Chr(ch)
For x As long=1 To 8
For y As long=1 To 16
If Point(x,y,img)<>0 Then
count=count+1
XY(count,ch)=Type<D2>(x,y)
End If
Next y
Next x
count=0
imagedestroy img
Next ch
runflag=1
End If
If size=0 Then Exit Sub
Dim As D2 np,t
#macro Scale(p1,p2,d)
np.col=p2.col
np.x=d*(p2.x-p1.x)+p1.x
np.y=d*(p2.y-p1.y)+p1.y
#endmacro
Dim As D2 c=Type<D2>(xpos,ypos)
Dim As long dx=xpos,dy=ypos
For z6 As long=1 To Len(text)
Var asci=text[z6-1]
For _x1 As long=1 To 64*2
t=Type<D2>(XY(_x1,asci).x+dx,XY(_x1,asci).y+dy,colour)
Scale(c,t,size)
cpt(_x1)=np
If XY(_x1,asci).x<>0 Then
If Abs(size)>1 Then
Line im,(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+8
Next z6
End Sub
Sub initfont Constructor 'automatic loader
drawstring(0,0,"",0,0)
SCREEN 0, , , &h80000000
End Sub
function Colour(im as any pointer,newcol as ulong,tweak as long,fontsize as long) as any pointer
#macro ppset2(_x,_y,colour)
pixel2=row2+pitch2*(_y)+(_x)*dpp2
*pixel2=(colour)
#endmacro
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*dpp
(colour)=*pixel
#endmacro
dim as long grade
select case as const fontsize
case 1:grade=200
case 2:grade=225
case 3:grade=200
case 4:grade=190
case 5:grade=165
case else: grade=160
end select
dim as long w,h
Dim As long pitch,pitch2
Dim As Any Pointer row,row2
Dim As Ulong Pointer pixel,pixel2
Dim As Ulong col
dim as long dpp,dpp2
Imageinfo im,w,h,dpp,pitch,row
dim as any pointer temp
temp=imagecreate(w,h)
Imageinfo temp,,,dpp2,pitch2,row2
for y as long=0 to h-1
for x as long=0 to w-1
ppoint(x,y,col)
Var v=.299*((col Shr 16)And 255)+.587*((col Shr 8)And 255)+.114*(col And 255)
if v>(grade+tweak) then
ppset2(x,y,newcol)
else
ppset2(x,y,rgb(255,0,255))
end if
next x
next y
return temp
end function
sub CreateFont(byref myfont as any pointer,fontsize as long,col as ulong,tweak as long=0)
Const FIRSTCHAR =32,LASTCHAR=127
Const NUMCHARS=(LASTCHAR-FIRSTCHAR)+1
Dim As ubyte Ptr p
dim as any pointer temp
Dim As long i
temp = ImageCreate(NUMCHARS*8*FontSize,16*FontSize,rgb(255,0,255))
myfont=ImageCreate(NUMCHARS*8*FontSize,16*FontSize,rgb(255,0,255))
For i = FIRSTCHAR To LASTCHAR
drawstring ((i - FIRSTCHAR) * 8*FontSize, 1,chr(i),rgb(255,255,255),FontSize,temp)
Next i
if fontsize<=0 then fontsize=1
if fontsize>1 then
for n as long=0 to fontsize-2
temp=filter(temp,1,1,0)
next n
end if
temp=Colour(temp,col,tweak,fontsize)
put myfont,(0,0),temp,trans
ImageInfo( myfont,,,,, p )
p[0]=0
p[1]=FIRSTCHAR
p[2]=LASTCHAR
For i = FIRSTCHAR To LASTCHAR
p[3+i-FIRSTCHAR]=8*FontSize
next i
imagedestroy(temp)
end sub
'=================== END FONT SETUP ========================================
'======================================================================
screen 20,32
color , rgb(0,100,100)
dim as any ptr f0,f1,f2
createfont f0, 4,rgb(255,255,0)
createfont f1,3,rgb(0,0,100)
createfont f2,2,rgb(0,200,0)
dim as long x
do
x+=2
if x>1024 then x=0
screenlock
cls
draw string(50,50),str(timer),,f0
draw string (x,200),__function__,,f1
draw string (x-1024,200),__function__,,f1
draw string (50,500),"Press escape to end . . .",,f2
screenunlock
sleep 1
loop until inkey=chr(27)
Code: Select all
' xyz_8acolour.bas
' x, y, z planes .
'
' -----------------------------------------------------------------------------
'
' My graf 3d
'
' (c) copyright 2022 , sciwiseg@gmail.com ,
'
' Edward.Q.Montague. [ alias]
'
' Just use BLOAD and PCOPY to bring in extensive text and images from elsewhere!
'
' -----------------------------------------------------------------------------
'
type point
x as single
y as single
z as single
u as single ' possible extension for special coord system
end type
'
const Pi = 4*atn(1)
'
dim as single x1,y1,z1,x2,y2,z2
dim as integer i,j,k
'
'
'
dim as point p1(1 to 8)
dim as integer edge(1 to 12,0 to 1)
'
' Looking at a cube .
'
' -1,1 _______<_______ 1,1 start z = -1
' | | back face.
' | |
' v ^
' | |
' |_______________|
' -1,-1 > 1,-1
'
'
' -----------------------------------------------------------------------------
'
declare function rotx(q as point,angx as single) as point
declare function roty(q as point,angy as single) as point
declare function rotz(q as point,angz as single) as point
declare function tranx(q as point,movx as single) as point
declare function trany(q as point,movy as single) as point
declare function tranz(q as point,movz as single) as point
declare function persp(q as point,d as single) as point
'
declare function Trall( p1() as point,n as integer,edge() as integer, div as integer ) as integer
declare sub drw_vertices(p1() as point, thi as single, colour as single, al as single)
declare sub drw_cube(p1() as point,edge() as integer, thi as single)
declare Function spectrum(x As Single,al As Ubyte=255) As Ulong
declare sub spectra()
'
declare sub drw_cube2(p1() as point,edge() as integer, thi as single,c1 as point)
'
'
declare sub Px1(edge() as integer, p1() as point, theta as single)
declare sub Px3(edge() as integer, p1() as point,p3() as point,p4() as point,p5() as point, theta as single)
declare sub Px4(edge() as integer, p1() as point,p3() as point,p4() as point,p5() as point, theta as single)
'
'
'
' ----------------------------------------------------------------------
'
const Pi=4*atn(1)
'
' ================================================================
'
'dim as point p1(1 to 8)
'dim as integer edge(1 to 12)
restore store1
for i=1 to 8
read p1(i).x
read p1(i).y
read p1(i).z
next i
'
restore store2
for i=1 to 12
read edge(i,0)
read edge(i,1)
next i
'
' -----------------------------------------------------------------------------
'
Screen 20,32,4,64
window (-1.5,-1.5)-(1.5,1.5)
'line (-1,-1)-(1,1),rgb(12,200,200),b
'line (0,-1)-(0,1),rgb(12,200,200)
'line (-1,0)-(1,0),rgb(12,200,200)
'
' ------------------------------------------------------
'
dim as point p2(1 to 8)
dim as single theta,thi
dim as integer i1,j1,k1
'
theta = Pi/5
thi=0.32 ' [-1,1]
'
dim as point p3(1 to 5)
dim as point p4(1 to 5)
dim as point p5(1 to 5)
'
restore planexy
for i=1 to 5
read p3(i).x
read p3(i).y
read p3(i).z
next i
'
restore planeyz
for i=1 to 5
read p4(i).x
read p4(i).y
read p4(i).z
next i
'
restore planexz
for i=1 to 5
read p5(i).x
read p5(i).y
read p5(i).z
next i
'
' ---------------------------------------------------------------------
'
ScreenSet 1, 0
print" "
print" "
print " We control the y"
print " We control the z"
print " We control the x"
line (-1.46,1.4)-(-1.03,1.15),rgb(12,200,200),b
PCopy 1, 0
'
' -------------------- call various routines ---------------------------
'
spectra() ' using adjusted dodicat spectrum code .
'''Px1(edge() , p1() , theta ) ' voxel rapdly moving through cube .
''Px3(edge(),p1(),p3(),p4(),p5(),theta) ' 0.06s to render a pixel volume, cloud white only.
Px4(edge(), p1(),p3(),p4(),p5(), theta) ' 0.355s to render a coloured pixel volume, cloud
sleep
end
'
' ===================================
'
' vertex data , easier to keep track of
' data when we use multiple data statements.
'
store1: ' --> p1() , global
data 1,1,1
data -1,1,1
data-1,-1,1
data 1,-1,1
data 1,1,-1
data -1,1,-1
data -1,-1,-1
data 1,-1,-1
'
' edge data
'
store2: ' --> edge()
data 1,2
data 1,4
data 1,5
data 2,3
data 2,6
data 3,4
data 3,7
data 4,8
data 5,6
data 5,8
data 6,7
data 7,8
'
' vertex data
'
planexy: ' [-1,-1,0],[-1,1,0],[1,1,0],[1,-1,0],[-1,-1,0] --> P3() , global
data -1,-1,0
data -1,1,0
data 1,1,0
data 1,-1,0
data -1,-1,0
'
planeyz: ' [0,1,1],[0,-1,1],[0,-1,-1],[0,1,-1],[0,1,1] --> P4() , global
data 0,-1,-1
data 0,1,-1
data 0,1,1
data 0,-1,1
data 0,-1,-1
'data 0,1,1
'
planexz: ' [-1,0,-1],[-1,0,1],[1,0,1],[1,0,-1],[-1,0,-1] --> P5() , global
data -1,0,-1
data -1,0,1
data 1,0,1
data 1,0,-1
data -1,0,-1
'
' -------------------------------------------------------------------------------
'
function rotx(q as point,angx as single) as point
'
' Rotate around x axis .
'
static as point p
'
p.x = q.x
p.y= q.y*cos(angx)-sin(angx)*q.z
p.z= q.z*cos(angx)+sin(angx)*q.y
'
return p
'
end function
'
' -----------------------------------------------------------------------------
'
function roty(q as point,angy as single) as point
'
' Rotate around y axis .
'
static as point p
'
p.x = sin(angy)*q.z + cos(angy)*q.x
p.y = q.y
p.z = cos(angy)*q.z -sin(angy)*q.x
'
return p
'
end function
'
' -----------------------------------------------------------------------------
'
function rotz(q as point,angz as single) as point
'
' Rotate around z axis .
'
static as point p
'
p.x = sin(angz)*q.y + cos(angz)*q.x
p.y = cos(angz)*q.y-sin(angz)*q.x
p.z = q.z
'
return p
'
end function
'
' -----------------------------------------------------------------------------
'
function tranx(q as point,movx as single) as point
'
' Translate point along x axis
'
static as point p
'
p.x=q.x + movx
p.y=q.y
p.z=q.z
'
return p
'
end function
'
' -----------------------------------------------------------------------------
'
function trany(q as point,movy as single) as point
'
' Translate point along y axis
'
static as point p
'
p.x=q.x
p.y=q.y + movy
p.z=q.z
'
return p
'
end function
'
' -----------------------------------------------------------------------------
'
function tranz(q as point,movz as single) as point
'
' Translate point along z axis
'
static as point p
'
p.x=q.x
p.y=q.y
p.z=q.z + movz
'
return p
'
end function
'
' -----------------------------------------------------------------------------
'
function persp(q as point,d as single) as point
'
' 3d perspective .
'
' The numerator must always be positive.
'
static as point p
'
p.x = d*q.x/(q.z*0.25+1)
p.y = d*q.y/(q.z*0.25+1)
p.z = d
'
return p
'
end function
'
' -----------------------------------------------------------------------------
'
function Trall( p1() as point,n as integer,edge() as integer, div as integer ) as integer
'
' Translate and rotate all vertices .
' as an animation , for n cycles .
'
' With div number of angle divisions .
'
static as point p2(1 to 8)
static as single theta,thi,x1,y1,z1,x2,y2,z2
static as integer i,j,k
static as integer i1,j1,k1
'
theta = Pi/div
'
for i=1 to n
for j = 0 to div
cls
thi = j*theta
for k = 1 to 8
p2(k) = roty(p1(k),thi)
p2(k)=persp(p2(k),0.8)
next k
'
for i1 = 1 to 12
j1 = edge(i1,0)
k1 = edge(i1,1)
x1 = p2(j1).x
y1 = p2(j1).y
' z1 = p2(j1).z
x2 = p2(k1).x
y2 = p2(k1).y
' z2 = p2(k1).z
line(x1,y1)-(x2,y2),14
next i1
'
sleep 100
next j
next i
'
return 0
'
end function
'
' ----------------------------------------------------------------------
'
sub drw_cube(p1() as point,edge() as integer, thi as single)
'
' draw encompassing cube .
'
static as integer lv, k
static as single x1, y1, x2, y2
static as integer i1,j1,k1
'
lv = ubound(p1,1)
'
dim p2(1 to lv) as point
for k = 1 to 8
p2(k) = roty(p1(k),thi)
p2(k) = rotx(p2(k),-thi/4)
p2(k) = persp(p2(k),0.8)
next k
'
for i1 = 1 to 12
j1 = edge(i1,0)
k1 = edge(i1,1)
x1 = p2(j1).x
y1 = p2(j1).y
' z1 = p2(j1).z
x2 = p2(k1).x
y2 = p2(k1).y
' z2 = p2(k1).z
line(x1,y1)-(x2,y2),rgb(200,180,20)
next i1
'
end sub
'
' ----------------------------------------------------------------------
'
sub drw_cube2(p1() as point,edge() as integer, thi as single,c1 as point)
'
' draw encompassing cube .
'
static as integer lv, k
static as single x1, y1, x2, y2
static as integer i1,j1,k1
'
lv = ubound(p1,1)
'
dim p2(1 to lv) as point
for k = 1 to 8
p2(k) = roty(p1(k),thi)
p2(k) = rotx(p2(k),-thi/4)
p2(k) = persp(p2(k),0.8)
next k
'
for i1 = 1 to 12
j1 = edge(i1,0)
k1 = edge(i1,1)
x1 = p2(j1).x
y1 = p2(j1).y
' z1 = p2(j1).z
x2 = p2(k1).x
y2 = p2(k1).y
' z2 = p2(k1).z
'line(x1,y1)-(x2,y2),rgba(c1.x*255,c1.y*255,c1.z*255,c1.u*255)
pset(x1,y1),rgba(c1.x*255,c1.y*255,c1.z*255,c1.u*255)
next i1
'
end sub
'
'
' ----------------------------------------------------------------------
'
sub drw_vertices(p1() as point, thi as single, colour as single, al as single)
'
' draw a connected set of vertices, without using edge data .
'
static as integer lv, k
static as single x1, y1, x2, y2
static as ulong pxc
lv = ubound(p1,1)
static p8(1 to lv) as point
for k = 1 to lv
p8(k) = roty(p1(k),thi)
p8(k) = rotx(p8(k),-thi/4)
p8(k) = persp(p8(k),0.8)
next k
pxc=rgb(0,0,0)
pxc = spectrum(colour,al) ' [colour,[0,1]] , [al,[0,255]] ?
for k = 1 to lv-1
x1 = p8(k).x
y1 = p8(k).y
x2 = p8(k+1).x
y2 = p8(k+1).y
line(x1,y1)-(x2,y2),pxc
next k
'
end sub
' ----------------------------------------------------------------------
'
' 0.51 yellow , 0.0 green
'
'
sub spectra()
'
' Colours from function spectrum .
'
'
static as single x1,y1,x2,y2
'
line(-1,-0.5)-(1,0.5),rgb(255,255,255),b
for x1=-1 to 1-0.001 step 0.001
line(x1,-0.5)-(x1+0.001,0.5),spectrum(x1,200),bf
next x1
line(-1,-0.5)-(1,0.5),rgb(255,255,255),b
'
locate 14,55
print " Colour palette used "
locate 34,20
print "-1"
locate 34,55
print " some variable "
locate 34,107
print "+1"
PCopy 1, 0
sleep 12000
exit sub
line(-1,-0.5)-(1,0.5),rgb(0,0,0),bf
line(-1,-0.5)-(1,0.5),rgb(255,255,255),b
for x1=-1 to 1-0.01 step 0.001
x2=x1+0.01
y1=sin(Pi*x1)+1
y2=sin(Pi*x2)+1
if (y1>1) then
line(x1,-0.5)-(x1+0.01,0.5),spectrum(1.65,abs(y1-1)*127),bf ' 1.5
else
line(x1,-0.5)-(x1+0.01,0.5),spectrum(5.85,abs(y1-1)*127),bf ' -1.4
end if
line(x1,y1-1)-(x2,y2-1),rgb(240,240,240)
next x1
line(-1,-0.5)-(1,0.5),rgb(255,255,255),b
'
' x 1.5 , -1.4 , red , blue .
sleep 2022
end sub
'
' ----------------------------------------------------------------------
'
Function spectrum(x As Single,al As Ubyte=255) As Ulong
' from dodicat, FreeBasic community .
' [x, [-1, 1]]
' a = -2.528
' b = 3.808
' y = a*x + b
' purple,blue,cyan,green,yellow,orange,red .
x = -2.528*x + 3.808
return rgba((Sin(x)*127+128),_
(Sin((x-2.0944))*127+128),_
(Sin((x+2.0944))*127+128),al)
End Function
'
' ---------------------------------------------------------
'
sub Px1(edge() as integer, p1() as point, theta as single)
'
' voxel rapdly moving through cube .
'
dim as single movy,movx,movz,dm
dim as integer snooze,i
dim as point c1
c1.x=1
c1.y=1
c1.z=1
c1.u=0.5
dm=0.1'1/64
'dm=1/64
snooze=0.0001
snooze=10
cls
ScreenSet 1, 0
drw_cube(p1(), edge(), theta)
dim p1a(1 to 8) as point
for i=1 to 8
p1a(i).x = p1(i).x*0.02
p1a(i).y = p1(i).y*0.02
p1a(i).z = p1(i).z*0.02
next i
'
drw_cube(p1a(), edge(), theta)
'
'dim as single t1, t2
dim as point q1(1 to 8)
'
't1=timer
for movz=-1 to 1.01 step dm
for movy=-1.0 to 1.01 step dm
' drw_cube(p1(), edge(), theta)
for movx=-1.0 to 1.01 step dm
line (-1.5,-1.5)-(1.5,1.5),rgb(0,0,0),bf
drw_cube(p1(), edge(), theta)
for i=1 to 8
q1(i).x=p1a(i).x+movx
q1(i).y=p1a(i).y+movy
q1(i).z=p1a(i).z+movz
next i
drw_cube2(q1(), edge(), theta,c1)
PCopy 1, 0
sleep snooze
next movx
sleep snooze
'PCopy 1, 0
next movy
sleep snooze
next movz
't2=timer
'print " elapsed time = ";t2-t1
sleep 2022
end sub
'
' ---------------------------------------------------------
'
sub Px3(edge() as integer, p1() as point,p3() as point,p4() as point,p5() as point, theta as single)
'
' Render a pixel volume .
'
dim as integer i, j, k, idx, jdx, kdx
dim as ulong axv(1 to 64,1 to 64,1 to 64), cxv
dim as point pxv, qxv
dim as single x,y
dim as point c1
c1.x=1
c1.y=1
c1.z=1
c1.u=0.5
'
for k=1 to 64
for j=1 to 64
for i=1 to 64
axv(i,j,k)=0
next i
next j
next k
'
for k=20 to 30
for j=10 to 30
for i=15 to 38
axv(i,j,k)=1
next i
next j
next k
'
dim as single movy,movx,movz,dm
'cls
'drw_cube(p1(), edge(), theta)
dm=2/64
dim as integer snooze
snooze=0.01
'cls
ScreenSet 1, 0
line(-1,1.01)-(1,1.5),rgb(0,0,0),bf
locate 4,44
print " Draw a volume comprised of pixels "
locate 5,44
print " White base colour "
PCopy 1, 0
'
drw_cube(p1(), edge(), theta)
dim p1a(1 to 8) as point
dim q5(1 to 5) as point
dim q4(1 to 5) as point
dim q3(1 to 5) as point
for i=1 to 8
p1a(i).x = p1(i).x*0.02
p1a(i).y = p1(i).y*0.02
p1a(i).z = p1(i).z*0.02
next i
'
'drw_cube(p1a(), edge(), theta)
'
dim as double t1, t2
dim as point q1(1 to 8)
'
t1=timer
kdx=1
for movz=1 to -1.0 step -dm
jdx=1
for movy=-1.0 to 1.0 step dm
idx=1
for movx=-1.0 to 1.0 step dm
' drw_cube(p1(), edge(), theta)
for i=1 to 8
q1(i).x=p1a(i).x+movx
q1(i).y=p1a(i).y+movy
q1(i).z=p1a(i).z+movz
next i
'
cxv=axv(idx,jdx,kdx)
c1.x=cxv
c1.y=cxv
c1.z=cxv
c1.u=0.5
'
if cxv>0 then drw_cube2(q1(), edge(), theta,c1)
' if cxv>0 then pset(q1(1).x,q1(1).y),rgba(255*cxv,255*cxv,255*cxv,127)
'
idx=idx+1
if idx>64 then idx=64
next movx
jdx=jdx+1
if jdx>64 then jdx=64
next movy
drw_cube(p1(), edge(), theta)
PCopy 1, 0
kdx=kdx+1
if kdx>64 then kdx=64
next movz
'
t2=timer
locate 46,2
print " elapsed time = ";t2-t1
PCopy 1, 0
sleep 2022
end sub
'
' ---------------------------------------------------------
'
sub Px4(edge() as integer, p1() as point,p3() as point,p4() as point,p5() as point, theta as single)
'
' Draw a volume of pixels, colour from rgb .
'
dim as integer i, j, k, idx, jdx, kdx, n, m, p
dim as point pxv, qxv
dim as single x,y,z
dim as point c1
dim as ubyte red,grn,blue,flg1,flg2,flg3
'
n=128
m=n
p=n
dim as ulong axv(1 to n,1 to m,1 to p), cxv
c1.x=1
c1.y=1
c1.z=1
c1.u=0.5
'
for k=1 to p
for j=1 to m
for i=1 to n
axv(i,j,k)=0
next i
next j
next k
'
for k=1 to p
z=-1+2*(k-1)/p
flg1=0
if (z>-0.3) and (z< 0.2) then flg1=1
for j=1 to m
y=-1+2*(j-1)/m
flg2=0
if (y>-0.147) and (y< 0.253) then flg2=1
for i=1 to n
x=-1+2*(i-1)/n
red=0
grn=0
blue=0
flg3=0
if (x>-0.4) and (x< 0.36) then flg3=1
'
if (flg1=1) and (flg2=1) and (flg3=1) then
red=200*((k-1)/p) +50
blue=200*((i-1)/n) +50
grn=200*((j-1)/m) +50
axv(i,j,k)=rgba(red,grn,blue,127)
end if
'
next i
next j
next k
'
dim as single movy,movx,movz,dm
dim as integer snooze
dim p1a(1 to 8) as point
dim q5(1 to 5) as point
dim q4(1 to 5) as point
dim q3(1 to 5) as point
dim as double t1, t2
dim as point q1(1 to 8)
dim as point pd, qd
'
dm=2/m
snooze=0.01
for i=1 to 8
p1a(i).x = p1(i).x*0.02
p1a(i).y = p1(i).y*0.02
p1a(i).z = p1(i).z*0.02
next i
'
pd.x=p1a(1).x
pd.y=p1a(1).y
pd.z=p1a(1).z
'
ScreenSet 1, 0
line (-1.5,-1.5)-(1.5,1.5),rgb(0,0,0),bf
'cls
locate 4,44
print " Draw a volume comprised of pixels "
locate 5,44
print " Spectra base colours "
PCopy 1, 0
'
'
'drw_cube(p1a(), edge(), theta)
'
t1=timer
kdx=1
for movz=1 to -1.0 step -dm
jdx=1
for movy=-1.0 to 1.0 step dm
idx=1
for movx=-1.0 to 1.0 step dm
' drw_cube(p1(), edge(), theta)
qd.x=pd.x+movx
qd.y=pd.y+movy
qd.z=pd.z+movz
'
cxv=axv(idx,jdx,kdx)
'
qd = roty(qd,theta)
qd = rotx(qd,-theta/4)
qd = persp(qd,0.8)
'
if cxv>0 then pset(qd.x,qd.y),cxv
'
idx=idx+1
if idx>n then idx=n
next movx
jdx=jdx+1
if jdx>m then jdx=m
next movy
drw_cube(p1(), edge(), theta)
PCopy 1, 0
kdx=kdx+1
if kdx>p then kdx=p
next movz
'
t2=timer
locate 46,2
print " elapsed time = ";t2-t1
PCopy 1, 0
sleep 4022
end sub
'
' ---------------------------------------------------------
'
Code: Select all
'
'
' Freebasic : luxan
' sciwiseg@gmail.com
'
'
#Include Once "GL/gl.bi"
#Include Once "GL/glu.bi"
#Include Once "GL/glut.bi"
#include once "math.bi"
Declare Sub doMain()
Declare Sub doShutdown()
Declare Sub drawCube()
Declare Sub drawSincFunctionSurface()
Declare Sub drawSincFunctionSurfaceG()
Declare Sub drawSincFunction(ByVal x As Single, ByVal y As Single, ByRef z As Single)
Declare sub minmax_z(min_z as single,max_z as single)
Declare Sub GetSincColor(ByVal z As Single, color1() As Single)
Declare Sub createLightSpectrumColormap(colormap() As Single)
Declare Sub createColorMap(colormap() As Single)
Declare Sub mapValueToColor(value As Single, colormap() As Single)
Dim shared As Single angleX = 0.0
Dim shared As Single angleY = 0.0
Dim shared As Integer lastMouseX, lastMouseY
Dim shared As Integer isMouseDragging = False
' Global variable for limit
Dim shared As Single limit = 1.0
ReDim As Single colormap(24) ' declare a variable length array .
Print " Overture, curve the lights"
doMain
End
Sub doRender CDecl
Static rtri As Single
Static rqud As Single
glClear GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT
glPushMatrix
glLoadIdentity
glTranslatef 0.0, 0.0, -5.0
glRotatef angleX, 1.0, 0.0, 0.0
glRotatef angleY, 0.0, 1.0, 0.0
' Draw the cube
glColor3f(1.0, 1.0, 1.0)
drawCube()
' Draw the sinc function surface within the cube
drawSincFunctionSurface()
drawSincFunctionSurfaceG()
' reDraw the cube
glColor3f(1.0, 1.0, 1.0)
drawCube()
glFlush
glutSwapBuffers
rtri = rtri + 2.0
rqud = rqud + 1.5
End Sub
Sub drawCube()
Dim As Single limit = 1.0
glBegin(GL_LINES)
' Front face
glVertex3f(-limit, -limit, limit)
glVertex3f(limit, -limit, limit)
glVertex3f(limit, -limit, limit)
glVertex3f(limit, limit, limit)
glVertex3f(limit, limit, limit)
glVertex3f(-limit, limit, limit)
glVertex3f(-limit, limit, limit)
glVertex3f(-limit, -limit, limit)
' Back face
glVertex3f(-limit, -limit, -limit)
glVertex3f(limit, -limit, -limit)
glVertex3f(limit, -limit, -limit)
glVertex3f(limit, limit, -limit)
glVertex3f(limit, limit, -limit)
glVertex3f(-limit, limit, -limit)
glVertex3f(-limit, limit, -limit)
glVertex3f(-limit, -limit, -limit)
' Connecting lines
glVertex3f(-limit, -limit, limit)
glVertex3f(-limit, -limit, -limit)
glVertex3f(limit, -limit, limit)
glVertex3f(limit, -limit, -limit)
glVertex3f(limit, limit, limit)
glVertex3f(limit, limit, -limit)
glVertex3f(-limit, limit, limit)
glVertex3f(-limit, limit, -limit)
glEnd()
End Sub
Sub GetSincColor(ByVal z As Single, color1() As Single)
Dim As Single t = z
If t < -1.0 Then t = -1.0
If t > 1.0 Then t = 1.0
If t < 0 Then
color1(0) = 0.0
color1(1) = 0.0
color1(2) = -t ' Blue component
Else
color1(0) = t ' Red component
color1(1) = 0.0
color1(2) = 0.0
End If
End Sub
Sub drawSincFunction(ByVal x As Single, ByVal y As Single, ByRef z As Single)
Dim As Single r = Sqr(x * x + y * y)
If r < 0.001 Then
z = 1.0
Else
z = Sin(10.0 * r * M_PI) / (10.0 * r * M_PI) + Cos(x*M_PI*5)*0.035
End If
End Sub
Sub createLightSpectrumColormap(colormap() As Single)
ReDim As Single colormap(24) ' 8 colors x 3 components (RGB) = 24 values
' Define colors for different parts of the spectrum (ROYGBIV)
' Red
colormap(0) = 1.0
colormap(1) = 0.0
colormap(2) = 0.0
' Orange
colormap(3) = 1.0
colormap(4) = 0.5
colormap(5) = 0.0
' Yellow
colormap(6) = 1.0
colormap(7) = 1.0
colormap(8) = 0.0
' Green
colormap(9) = 0.0
colormap(10) = 1.0
colormap(11) = 0.0
' Blue
colormap(12) = 0.0
colormap(13) = 0.0
colormap(14) = 1.0
' Indigo
colormap(15) = 0.294
colormap(16) = 0.0
colormap(17) = 0.51
' Violet
colormap(18) = 0.6
colormap(19) = 0.0
colormap(20) = 1.0
' Ultraviolet
colormap(21) = 0.65
colormap(22) = 0.0
colormap(23) = 0.65
End Sub
Sub createColorMap(colormap() As Single)
ReDim As Single colormap(8) ' 3 colors x 3 components (RGB) = 9 values
' Define your colormap here, for example:
' R, G, B values for 0.0 to 1.0 magnitude
colormap(0) = 0.0
colormap(1) = 0.0
colormap(2) = 1.0 ' Blue for low magnitude
colormap(3) = 0.0
colormap(4) = 1.0
colormap(5) = 0.0 ' Green for medium magnitude
colormap(6) = 1.0
colormap(7) = 0.0
colormap(8) = 0.0 ' Red for high magnitude
End Sub
Sub mapValueToColor(value As Single, colormap() As Single)
Dim numColors As Integer
numColors = UBound(colormap) \ 3 + 1
Dim index As Integer
index = Int(value * (numColors - 1))
If index < 0 Then
glColor3f(colormap(0), colormap(1), colormap(2))
ElseIf index >= numColors - 1 Then
glColor3f(colormap((numColors - 1) * 3), colormap((numColors - 1) * 3 + 1), colormap((numColors - 1) * 3 + 2))
Else
Dim t As Single
t = value * (numColors - 1) - index
Dim r As Single
Dim g As Single
Dim b As Single
r = (1.0 - t) * colormap(index * 3) + t * colormap((index + 1) * 3)
g = (1.0 - t) * colormap(index * 3 + 1) + t * colormap((index + 1) * 3 + 1)
b = (1.0 - t) * colormap(index * 3 + 2) + t * colormap((index + 1) * 3 + 2)
glColor3f(r, g, b)
End If
End Sub
Sub doInput CDecl(ByVal kbcode As Unsigned Byte, ByVal mousex As Long, ByVal mousey As Long)
If (kbcode = 27) Then
doShutdown
End 0
End If
End Sub
Sub mouseMotion(ByVal x As Long, ByVal y As Long)
If (isMouseDragging) Then
Dim deltaX As Integer = x - lastMouseX
Dim deltaY As Integer = y - lastMouseY
angleX += deltaY * 0.5
angleY += deltaX * 0.5
lastMouseX = x
lastMouseY = y
glutPostRedisplay
End If
End Sub
Sub mouse(ByVal button As Long, ByVal state As Long, ByVal x As Long, ByVal y As Long)
If (button = GLUT_LEFT_BUTTON) Then
If (state = GLUT_DOWN) Then
isMouseDragging = True
lastMouseX = x
lastMouseY = y
ElseIf (state = GLUT_UP) Then
isMouseDragging = False
End If
End If
End Sub
Sub doReshapeGL(ByVal w As Long, ByVal h As Long)
glViewport 0, 0, w, h
glMatrixMode GL_PROJECTION
glLoadIdentity
If (h = 0) Then
gluPerspective(45.0, w, 1.0, 100.0)
Else
gluPerspective(45.0, w / h, 1.0, 100.0)
End If
glMatrixMode GL_MODELVIEW
glLoadIdentity
End Sub
Sub initGLUT()
glutInit(1, StrPtr(" "))
glutInitWindowPosition 0, 0
glutInitWindowSize 800, 600
glutInitDisplayMode GLUT_DOUBLE Or GLUT_RGB Or GLUT_DEPTH
glutCreateWindow("Wireframe Cube with Sinc Function")
glEnable(GL_DEPTH_TEST)
glutDisplayFunc(@doRender)
glutReshapeFunc(@doReshapeGL)
glutKeyboardFunc(@doInput)
' Register mouse callback functions
glutMouseFunc(@mouse)
glutMotionFunc(@mouseMotion)
glutMainLoop
End Sub
Sub doInit()
initGLUT
End Sub
Sub shutdownGLUT()
' GLUT shutdown will be done automatically by atexit()...
End Sub
Sub doShutdown()
shutdownGLUT
End Sub
Sub doMain()
doInit
End Sub
Sub drawSincFunctionSurface()
Dim As Single limit = 1.0
Dim As Integer numSegments = 100
' Find min, max for function defined at drawSincFunction.
Dim As Single min_z, max_z, max_m
minmax_z(min_z ,max_z )
max_m=abs(min_z)
if abs(max_z)>max_m then max_m=abs(max_z)
if max_m = 0 then max_m=1
'
Dim colormap() As Single
createLightSpectrumColormap(colormap())
For i As Integer = 0 To numSegments - 1
Dim x0 As Single = -limit + i * 2 * limit / (numSegments )
Dim x1 As Single = -limit + (i + 1) * 2 * limit / (numSegments )
glBegin(GL_TRIANGLE_STRIP)
For j As Integer = 0 To numSegments
Dim y As Single = -limit + j * 2 * limit / (numSegments )
' Calculate z values using drawSincFunction
Dim z0 As Single, z1 As Single
drawSincFunction(x0, y, z0)
drawSincFunction(x1, y, z1)
z0=z0/max_m
z1=z1/max_m
' Calculate magnitude of sinc function
Dim magnitude0 As Single = (z0 + 0.5) / 1.5 ' Normalize to [0, 1]
Dim magnitude1 As Single = (z1 + 0.5) / 1.5
' Map magnitude to color using the colormap
mapValueToColor(1 - magnitude0, colormap())
glVertex3f(x0, z0, y)
mapValueToColor(1 - magnitude1, colormap())
glVertex3f(x1, z1, y)
Next j
glEnd()
Next i
End Sub
'
'
' .....................................................................
'
Sub drawSincFunctionSurfaceG()
dim as integer i,j,numSegments
dim as single y
Dim As Single z0, z1, z2, z3
numSegments=100
Dim As Single y0, y1
Dim As Single x0, x1
' Find min, max for function defined at drawSincFunction.
Dim As Single min_z, max_z, max_m
minmax_z(min_z ,max_z )
max_m=abs(min_z)
if abs(max_z)>max_m then max_m=abs(max_z)
if max_m = 0 then max_m=1
'
'Exit sub
glBegin(GL_LINES)
glColor3f(1.0, 1.0, 1.0)
' glBegin(GL_TRIANGLE_STRIP)
For j = 0 To numSegments step 10
y0 = -limit + j * 2 * limit / (numSegments)
For i = 0 To numSegments - 1
x0 = -limit + i * 2 * limit / (numSegments )
x1 = -limit + (i + 1) * 2 * limit / (numSegments )
drawSincFunction(x0, y0, z0) ' <<
z0=z0/max_m
glVertex3f(x0, z0, y0) ' Bottom-left vertex
drawSincFunction(x1, y0, z1) ' <<
z1=z1/max_m
glVertex3f(x1, z1, y0) ' Bottom-right vertex
Next i
Next j
' glEnd()
' Exit sub
For i = 0 To numSegments step 10
x0 = -limit + i * 2 * limit / (numSegments )
For j = 0 To numSegments-1
y0 = -limit + j * 2 * limit / (numSegments )
y1 = -limit + (j + 1) * 2 * limit / (numSegments )
drawSincFunction(x0, y0, z0)
glVertex3f(x0, z0, y0) ' Bottom-left vertex
z0=z0/max_m
drawSincFunction(x0, y1, z3)
z3=z3/max_m
glVertex3f(x0, z3, y1) ' Top-left vertex
Next j
Next i
'
glEnd()
'
End Sub
'
' ______________________________________________________________________
'
sub minmax_z(min_z as single,max_z as single)
'
' Find the minimum and maximum magnitudes of the function
' within the default x and y ranges .
'
min_z=100
max_z=-100
'
Dim as integer i,j
Dim As Single limit = 1.0
Dim As Integer numSegments = 100
Dim as Single x0,y,z0
'
For i = 0 To numSegments
x0 = -limit + i * 2 * limit / (numSegments )
For j = 0 To numSegments
y = -limit + j * 2 * limit / (numSegments )
' Calculate z values using drawSincFunction
drawSincFunction(x0, y, z0)
if z0<min_z then min_z=z0 end if
if z0>max_z then max_z=z0 end if
Next j
Next i
'
end sub