3D Geometry , basics

Luxan · Post by **Luxan** » Nov 02, 2022 23:43

That's very creative, clouds are a nice addition.

I'm attempting to print large text to a screen, the Draw String example, from the FB documentation, runs
using the default font size beyond that there no options.
The myfont.bmp is generated and saved, this can be manipulated using Gimp ; I scaled the font image to a height
of 32 pixels. The put(x,y),image command works with this, the Draw String doesn't.
Yet all of this appears to be the most direct way to implement large fonts.

dodicat · Post by **dodicat** » Nov 03, 2022 16:28

Here are some fonts for draw string built on the system fonts.

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)

Luxan · Post by **Luxan** » Nov 08, 2022 5:33

A bit slow in my reply.

Yes, your fonts are almost spectacular.

You code for this incorporates a number of ideas , some that aren't that obvious.

With my coding I attempt to utilise the existing commands, sometimes in a round
about way.

I'm going to be busy for a week or so, therefore don't expect messages from me.

Luxan · Post by **Luxan** » Nov 16, 2022 17:49

I'm busy with other software and I'm learning about a
quite involved topic; therfore:

Just an illustration of a volume cloud quickly rendered;
from back to front.
This also uses alpha blending and the spectrum function
from dodicat.

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
'
' ---------------------------------------------------------
'

Luxan · Post by **Luxan** » Dec 09, 2022 7:19

Dodicat

I'm working on a few projects now, while attempting to recover from a minor injury.

In the GUI section, I recently posted a file for a very basic console gui ; the fonts are too small for my likening.

The fonts from your draw string example are either small or too large, might you produce a greater variety of sizes.

Luxan · Post by **Luxan** » Nov 11, 2023 5:49

A little graphics plotting program I've been writing,
with the help [65%] of ChatGPT and hindrance [30%]; my contribution
is indeterminate.

To get specular reflection from the surface of the [sinc] function,
the calculation of normal's is most likely required.

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

Luxan · Post by **Luxan** » Sep 14, 2024 23:28

This doesn't appear to do much; yet.

I found I was westling with a lot of other issues before I had the right
mind set to do this little bit of coding.

I corrected a bug where I was indexing arrays starting from 0,
whereas the first element is indexed with 1 .

Removing all of the clutter was also important.

There's no ChatGPT content in this code.

Code: Select all



'    x, y, z  planes .

'
' -----------------------------------------------------------------------------
'
'   cube_3d4.bas 
'
'    (c) copyright 2024 , sciwise@ihug.co.nz ,
'
'             Edward.Q.Montague.  [ alias]
'
'
'
'
'
' -----------------------------------------------------------------------------
'
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)
dim as integer edge5(1 to 4,0 to 1)
'
'                  Looking at a cube .
'
'               -1,1 _______<_______  1,1    start   z = -1
'                   |               |        back face.
'                   |               |
'                  v                ^
'                   |               |
'                   |_______________|
'              -1,-1        >         1,-1
'                
'
' -----------------------------------------------------------------------------
'
declare Function spectrum(x As Single,al As Ubyte=255) As Ulong
declare sub spectra()
'
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 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 sub rotate_x(p5a() as point, p5() as point,thi as single)
declare sub rotate_y(p5() as point, theta as single)
declare sub rotate_z(p5a() as point, p5() as point, theta as single)
'
' ================================================================
'
'  Make sure to read data correctly, observing bounds and limits .
'
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
'
restore store5
for i=1 to 4
   read edge5(i,0)
   read edge5(i,1)
next i
'
' -----------------------------------------------------------------------------
'
Screen 20,32,2,64

window (-1.5,-1.5)-(1.5,1.5)
line (-1.4,-1.4)-(1.4,1.4),11,b
'
' ------------------------------------------------------
'
dim as point p2(1 to 8)
dim as single theta,thi
dim as integer i1,j1,k1
'
theta = Pi/5
'
dim as point p3(1 to 5)
dim as point p4(1 to 5)
dim as point p5(1 to 5)
dim as point p5a(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 p5a(i).x
   read p5a(i).y
   read p5a(i).z
next i
'
print"   "
print"   "
print "   We control the y"
print "   We control the z"
print "   We control the x"
line (-1.5,1.4)-(-1.0,1.1),rgb(12,200,200),b
'
'spectra()
'
dim as single movy,movx,movz
ScreenSet 1, 0
'
' ..................
movy=0

for thi=-pi/8 to pi/8 step pi/64
   line (-1.5,-1.5)-(1.5,1.5),rgb(0,0,0),bf
   drw_cube(p1(), edge(), theta)
   rotate_x(p5a() ,p5(), thi)  '  y x
   drw_cube(p5(), edge5(), theta)
sleep 400 ' mSec ?   
PCopy 1, 0 
next thi

sleep 1200

' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

thi=pi/4
for thi=-pi/8 to pi/8 step pi/64
   line (-1.5,-1.5)-(1.5,1.5),rgb(0,0,0),bf
   drw_cube(p1(), edge(), theta)
   rotate_z(p5a() ,p5(), thi)
   drw_cube(p5(), edge5(), theta)
sleep 400
PCopy 1, 0 
next thi

sleep
end
'
' ======================================================================
'
' DATA statements for vertex data (store1)

storeZ:
data  1, 0, 1
data -1, 0, 1
data -1, 0, -1
data  1, 0, -1
data  1, 0, 1

data  1, 1, -1
data -1, 1, -1
data -1, -1, -1
data  1, -1, -1

'
' ===================================
'
'     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
'
store5:
data 1,2
data 2,3
data 3,4
data 4,1
'
' 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 .
'
dim 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 .  
'
'    Add 2 to the numerator when using any negative z value.
'
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
''
' ----------------------------------------------------------------------
'
sub drw_cube(p1() as point,edge() as integer, thi as single)
'
'                draw encompassing cube .
'
static as integer lv, k , ev
static as single x1, y1, x2, y2
static as integer i1,j1,k1
'
       lv = ubound(p1,1)
' 
'print " drw_cube , lv "; lv
      
dim p2(1 to lv) as point   

   for k = 1 to lv ' 8
     p2(k) = roty(p1(k),thi)
     p2(k) = rotx(p2(k),-thi/4)
     p2(k) = persp(p2(k),0.8)
   next k     
'
ev=ubound(edge,1)
'print " ev =";ev
'
for i1 = 1 to ev ' 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_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 = 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
'
' ----------------------------------------------------------------------
'
function spectrum(x As Single,al As Ubyte=255) As Ulong

'    from dodicat, FreeBasic community .


     return rgba((Sin(x)*127+128),_
                 (Sin((x-2.0944))*127+128),_
                 (Sin((x+2.0944))*127+128),al)
End Function
'
' ----------------------------------------------------------------------
'
sub spectra()
'
'
'
'
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.01 step 0.01
'  line(x1,-0.5)-(x1+0.01,0.5),spectrum((-x1+0.5)*3,200),bf
  line(x1,-0.5)-(x1+0.01,0.5),spectrum((1+x1)*3,200),bf
'  abs(y1-1)*127
next x1
line(-1,-0.5)-(1,0.5),rgb(255,255,255),b


'  red  1.65,  blue  5.85
'  green 3.45, yellow/orange 2.1
'  purple 0.12, cyan 4.8

sleep 18022

exit sub


x1=-0.45  ' red
print "  "
print "  "
print "     ";(1+x1)*3  ' 1.65      red
x1=0.95
print "     "; (1+x1)*3  ' 5.85    blue
'  red  1.65,  blue  5.85
x1=0.15 ' green
print "     "; (1+x1)*3  ' 3.45

x1=-0.3 ' yellow/orange
print "     "; (1+x1)*3  ' 2.1

' green 3.45, yellow/orange 2.1

x1=-0.96 ' purple
print "     "; (1+x1)*3  ' 0.12

x1=0.6 ' cyan
print "     "; (1+x1)*3  ' 4.8

' purple 0.12, cyan 4.8

line(x1,-0.5)-(x1,0.5),rgb(255,255,255)
'
'sleep

sleep 2022
'
'end

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
'
' ----------------------------------------------------------------------
'
sub rotate_x(p5a() as point, p5() as point,thi as single)
'
'  Rotate all available vertices around the x axis .
'
'
dim as point q
dim as integer i
'
for  i=1 to ubound(p5,1)
    q=p5a(i)
    q=rotx(q , thi) 
    p5(i)=q
next i
'
end sub
'
' ----------------------------------------------------------------------
'
sub rotate_y(p5() as point, theta as single)
'
'  Rotate all available vertices around the x axis .
'
'
dim as point q
dim as integer i
'
for  i=1 to ubound(p5,1)
    q=p5(i)
    q=roty(q , theta) 
    p5(i)=q  
next i
'
end sub
'
' ----------------------------------------------------------------------
'
sub rotate_z(p5a() as point, p5() as point, theta as single)
'
'  Rotate all available vertices around the x axis .
'
'
dim as point q
dim as integer i
'
for  i=1 to ubound(p5,1)
    q=p5a(i)
    q=rotz(q , theta) 
    p5(i)=q  
next i
'
end sub
'
' ----------------------------------------------------------------------
'

Luxan · Post by **Luxan** » Sep 17, 2024 4:00

The correct email address , in the copyright notice, is sciwiseg@gmail.com ; this being my current address.

Luxan · Post by **Luxan** » Sep 17, 2024 4:14

Henceforth, I intend to have six coding threads :

1. Freebasic code, exclusively developed by myself.
2. Freebasic code, exclusively developed by myself, that also includes contributions from ChatGPT, or
similar.
3. Freebasic code generated solely through ChatGPT, directed by myself.

Similar to previous, with the inclusion of code from collaborators.

dodicat · Post by **dodicat** » Sep 18, 2024 9:13

For fun Luxan, cube factory:

Code: Select all



Type v3
    As Double x,y,z
End Type

'standard opengl type cube faces used as the base cube
Dim Shared As V3 basecube(1 To 6,1 To 4)= _
{{(-1,-1,-1),(1,-1,-1),(1,1,-1),(-1,1,-1)},_'front
{(1,-1,-1),(1,-1,1),(1,1,1),(1,1,-1)},_ 'right
{(-1,-1,1),(1,-1,1),(1,1,1),(-1,1,1)},_'back
{(-1,-1,-1),(-1,-1,1),(-1,1,1),(-1,1,-1)},_'left
{(1,1,-1),(1,1,1),(-1,1,1),(-1,1,-1)},_'top
{(1,-1,-1),(1,-1,1),(-1,-1,1),(-1,-1,-1)}}'base

Type cube
    As v3 p(1 To 6,0 To 4)
    As v3 v1,v2 'ends of cube diagonals
    As v3 centre 
    As Long painter(1 To 6)
    Declare Constructor
    Declare Constructor(() As v3)
    As Ulong col(1 To 6)'colour each of six faces
End Type


Constructor cube
End Constructor

Constructor cube(a() As v3)
For r As Long=1 To 6
    For c As Long=1 To 4
        p(r,c)=a(r,c)
    Next
Next
'two corner diagonals
v1=p(1,1)
v2=p(2,3)
centre=Type<v3>((v1.x+v2.x)/2,(v1.y+v2.y)/2,(v1.z+v2.z)/2)
End Constructor

Sub CubeSort(c() As cube)
    For n As Long=Lbound(c) To Ubound(c)-1
        For m As Long=n+1 To Ubound(c)
            If c(n).centre.z<c(m).centre.z Then 
                Swap c(n),c(m)
            End If
        Next
    Next
End Sub

Function Expand(p() As V3,b As Single,shift As V3,i As Integer) As cube
    For n As Integer=Lbound(p,2) To Ubound(p,2)
        p(i,n).x=b*basecube(i,n).x+shift.x
        p(i,n).y=b*basecube(i,n).y+shift.y
        p(i,n).z=b*basecube(i,n).z+shift.z
    Next n
    Return cube(p())
End Function

Function createcube(size As Double,centre As v3)As cube
    Dim As v3 a(1 To 6,1 To 4)
    For i As Integer=Lbound(basecube,1) To Ubound(basecube,1)
        Expand (a(),size,centre,i)
    Next i
    Var k=cube(a())
    For n As Long=1 To 6
        k.col(n)=Rgb(Rnd*200,Rnd*200,Rnd*200)
    Next n
    Return k
End Function

Function Rotate(c As V3,p As V3,angle As V3,scale As V3=Type<V3>(1,1,1)) As V3
    Dim As Single sx=Sin(angle.x),sy=Sin(angle.y),sz=Sin(angle.z)
    Dim As Single cx=Cos(angle.x),cy=Cos(angle.y),cz=Cos(angle.z)
    Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
    Return Type<V3>((scale.x)*((cy*cz)*dx+(-cx*sz+sx*sy*cz)*dy+(sx*sz+cx*sy*cz)*dz)+c.x,_
    (scale.y)*((cy*sz)*dx+(cx*cz+sx*sy*sz)*dy+(-sx*cz+cx*sy*sz)*dz)+c.y,_
    (scale.z)*((-sy)*dx+(sx*cy)*dy+(cx*cy)*dz)+c.z)
End Function

Function perspective(p As V3,eyepoint As V3) As V3
    Dim As Double   w=1+(p.z/eyepoint.z)
    Return Type<V3>((p.x-eyepoint.x)/w+eyepoint.x,_
    (p.y-eyepoint.y)/w+eyepoint.y,_
    (p.z-eyepoint.z)/w+eyepoint.z)
End Function 

Function rotatecube(g1 As cube,angle As v3) As cube
    Dim As v3 fulcrum=Type<v3>((g1.v1.x+g1.v2.x)/2,(g1.v1.y+g1.v2.y)/2,(g1.v1.z+g1.v2.z)/2)
    Dim As cube tmp1=g1
    tmp1.centre=fulcrum
    Dim As v3 eye=Type(512,678/2,3000)
    Dim As Double cx,cy,cz
    For m As Integer=1 To 6
        cx=0:cy=0:cz=0
        For n As Integer=1 To 4
            tmp1.p(m,n)=Rotate(fulcrum,g1.p(m,n),angle)
            tmp1.p(m,n)=perspective(tmp1.p(m,n),eye)  'apply the eye (perspective)
            'accumulate cx,cy,cz
            cx+=tmp1.p(m,n).x:cy+=tmp1.p(m,n).y:cz+=tmp1.p(m,n).z
        Next n
        cx=cx/4:cy=cy/4:cz=cz/4
        'get face centroid into zero'th index of 2nd. dimension
        tmp1.p(m,0)=Type<v3>(cx,cy,cz)
    Next m
    'rotate the diagonal ends also
    tmp1.v1=Rotate(fulcrum,g1.v1,angle)
    tmp1.v2=Rotate(fulcrum,g1.v2,angle)
    Return tmp1
End Function

Sub movecubes(c() As cube)
    Dim As v3 fulcrum
    For k As Long=1 To Ubound(c)
        For n As Long=1 To 6
            For m As Long=1 To 4
                c(k).p(n,m).z-=30
            Next m
        Next n
        c(k).v1=c(k).p(1,1)
        c(k).v2=c(k).p(2,3)
        fulcrum=Type<v3>((c(k).v1.x+c(k).v2.x)/2,(c(k).v1.y+c(k).v2.y)/2,(c(k).v1.z+c(k).v2.z)/2)
        c(k).centre=fulcrum
    Next k
    
    For k As Long=1 To Ubound(c)
        If c(k).centre.z<-2700 Then
            c(k)=createcube(20,Type<v3>(100+Rnd*700,100+Rnd*500,3000+Rnd*5500))
        End If
    Next k
End Sub

Sub fill(p() As v3,c As Ulong,im As Any Ptr=0)
    #define ub Ubound
    Dim As Long Sy=1e6,By=-1e6,i,j,y,k
    Dim As Single a(Ub(p)+1,1),dx,dy
    For i =0 To Ub(p)
        a(i,0)=p(i).x
        a(i,1)=p(i).y
        If Sy>p(i).y Then Sy=p(i).y
        If By<p(i).y Then By=p(i).y
    Next i
    Dim As Single xi(Ub(a,1)),S(Ub(a,1))
    a(Ub(a,1),0) = a(0,0)
    a(Ub(a,1),1) = a(0,1)
    For i=0 To Ub(a,1)-1
        dy=a(i+1,1)-a(i,1)
        dx=a(i+1,0)-a(i,0)
        If dy=0 Then S(i)=1
        If dx=0 Then S(i)=0
        If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
    Next i
    For y=Sy-1 To By+1
        k=0
        For i=0 To Ub(a,1)-1
            If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
            (a(i,1)>y Andalso a(i+1,1)<=y) Then
            xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
            k+=1
        End If
    Next i
    For j=0 To k-2
        For i=0 To k-2
            If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
        Next i
    Next j
    For i = 0 To k - 2 Step 2
        Line im,(xi(i)+0,y)-(xi(i+1)+1-0,y),c
    Next i
Next y
End Sub

Sub DrawCubeFace(c As cube,i As Integer,colour As Ulong) 
    Static As v3 p0(3)
    For n As Long=1 To 4 'p0 is zero based array, so fill it correctly
        p0(n-1).x=c.p(i,n).x
        p0(n-1).y=c.p(i,n).y
        p0(n-1).z=c.p(i,n).z
    Next
    fill(p0(),colour)'colour each face
End Sub

Sub FaceSort(array As cube,painter() As Long)
    For p1 As Integer  = 1 To 5
        For p2 As Integer  = p1 + 1 To 6
            If array.p(p1,0).z<array.p(p2,0).z Then Swap painter(p1),painter(p2):Swap array.p(p1,0),array.p(p2,0)
        Next p2
    Next p1
End Sub

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

Sub drawfaces(tmp As cube,painter() As  Long,x() As Ulong)
    Dim As Ulong colour
    For z As Integer=Lbound(tmp.p,1)+3 To Ubound(tmp.p,1)'Paint only the closest three faces of each
        Var p=painter(z)
        colour=x(p)
        Select Case p
        Case 1: DrawCubeFace(tmp,p,colour)
        Case 2: DrawCubeFace(tmp,p,colour)
        Case 3: DrawCubeFace(tmp,p,colour)
        Case 4: DrawCubeFace(tmp,p,colour)
        Case 5: DrawCubeFace(tmp,p,colour)
        Case 6: DrawCubeFace(tmp,p,colour)
        End Select
    Next z
End Sub



Dim As Long numcubes=100

Dim As cube c(1 To numcubes)
Dim As cube tmp(1 To numcubes)
Randomize 2
For n As Long=1 To numcubes
    c(n)=createcube(20,Type<v3>(100+Rnd*600,100+Rnd*500,3000+Rnd*5500))
Next n

'start setting face painting order to default
For n As Long=1 To numcubes
    For m As Long=1 To 6
        c(n).painter(m)=m
    Next m
Next n

Dim As Long fps
Dim As Double a
Dim As v3 angle(1 To numcubes)
Dim As Double rnds(1 To numcubes)
For n As Long=1 To numcubes
    rnds(n)=(Rnd-Rnd)
Next n

Screenres 1024,768,32
width 1024\8,768\16


Do
    a+=.1
    
    For n As Long=1 To numcubes
        angle(n)=Type<v3>(rnds(n)*a/2,(rnds(n)-rnds(n))*a,-rnds(n)*a)
    Next n
    
    For n As Long=1 To numcubes
        tmp(n)= rotatecube(c(n),angle(n))
    Next n
    
    
    'reset face painting order
    For n As Long=1 To numcubes
        For m As Long=1 To 6
            tmp(n).painter(m)=m
        Next m
    Next n
    Screenlock
    Cls
    Draw String(10,30),"Frame Rate = " & fps,rgb(255,255,255)
    
    'sort the face centriods and cubes by .z value of centriods
    CubeSort(tmp())
    For n As Long=1 To numcubes
        FaceSort(tmp(n),tmp(n).painter())
    Next n
    
    For n As Long=1 To numcubes
        drawfaces(tmp(n),tmp(n).painter(),tmp(n).col()) 'c(2) is the moveable cube, so it is sent for adjustment
    Next n
    
    movecubes(c())
    'drawfaces(c(2),tmp(2),tmp(2).painter(),m,tmp(2).col()) 'm is the mouse
    
    Screenunlock
    
    Sleep regulate(60,fps),1
Loop Until Inkey=Chr(27)

shakirabelva · Post by **shakirabelva** » Sep 18, 2024 11:11

Informative!

dafhi · Post by **dafhi** » Sep 18, 2024 11:24

cubes!

nice formatting

Luxan · Post by **Luxan** » Sep 22, 2024 1:32

Yes, the many cubes is nice.

However the tilting plane , of my program, is a representation of the mechanism used for cyro-electron
tomography; without all of the details.

This representation may differ from the usual though, as my plane tilts in two directions.
One might imagine extra actuators to accomplish this.

Luxan · Post by **Luxan** » Oct 20, 2024 1:44

I happened to need the rotz routine , for a related project I've started.

I finally noticed I was using a reserved word, in particular 'point' .

Please replace all instances of 'point' with pnt, in all of my Geometry 3d routines and code.

Thereafter, point is to be used for its intended purpose, getting a value from a graphics
screen.

3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics

Re: 3D Geometry , basics