Icosahedron

[dodicat]

Click for colour.

Code: Select all

Type pt
    As Double x,y,z
End Type

Type triangle
    As pt p(0 To 2)
    As pt ctr
    As Ulong col
    As pt norm
End Type

Type angle3D             'FLOATS for angles
    As Single sx,sy,sz
    As Single cx,cy,cz
    Declare Static Function construct(As Single,As Single,As Single) As Angle3D
End Type

Function Angle3D.construct(x As Single,y As Single,z As Single) As Angle3D
    Return   Type (Sin(x),Sin(y),Sin(z), _
    Cos(x),Cos(y),Cos(z))
End Function

Function Rotate(c As pt,p As pt,a As Angle3D,scale As pt=Type(1,1,1)) As pt
    Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
    Return Type<pt>((scale.x)*((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.y)*((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.z)*((-a.sy)*dx+(a.sx*a.cy)*dy+(a.cx*a.cy)*dz)+c.z)
End Function

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

Function dot(p As pt,v2 As Pt) As Single 'dot product |v1| * |v2| *cos(angle between v1 and v2)
    Dim As Single d1=Sqr(p.x*p.x + p.y*p.y+ p.z*p.z),d2=Sqr(v2.x*v2.x + v2.y*v2.y +v2.z*v2.z)
    Dim As Single v1x=p.x/d1,v1y=p.y/d1,v1z=p.z/d1 'normalize
    Dim As Single v2x=v2.x/d2,v2y=v2.y/d2,v2z=v2.z/d2 'normalize
    Return (v1x*v2x+v1y*v2y+v1z*v2z)
End Function

Sub fill(p() As Pt,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)+1,y)-(xi(i+1)+1-1,y),c
    Next i
Next y
End Sub

Sub blow(d() As pt,t As pt,m As Double)
    For n As Long=1 To 12
        d(n).x=(d(n).x)*m+t.x
        d(n).y=(d(n).y)*m+t.y
        d(n).z=(d(n).z)*m+t.z
    Next
End Sub

Sub setup(p() As triangle,d() As pt,colours() As Ulong)
    Dim As Long i
    Dim As Double cx,cy,cz
    Dim As pt centre=Type(1024\2,768\2,0)
    For n As Long=1 To 20
        cx=0:cy=0:cz=0
        For k As Long=0 To 2
            Read i
            p(n).p(k)=d(i)
            cx+=d(i).x
            cy+=d(i).y
            cz+=d(i).z
        Next k
        p(n).ctr=Type(cx/3,cy/3,cz/3)
        p(n).norm=Type(p(n).ctr.x-centre.x,p(n).ctr.y-centre.y,p(n).ctr.z-centre.z)
        p(n).col=colours(n)
    Next n
    
End Sub

Sub shadow(p() As triangle)
    Dim As triangle tmp
    For n As Long=Lbound(p) To Ubound(p)
        tmp=p(n)
        tmp.p(0).x=p(n).p(0).x+200
        tmp.p(1).x=p(n).p(1).x+200
        tmp.p(2).x=p(n).p(2).x+200
        fill(tmp.p(),Rgba(0,0,0,100))
    Next n
End Sub

Sub show(p() As triangle)
    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
    Dim As pt lightsource
    lightsource=Type(.5,0,.5)
    For n As Long=Lbound(p)+9 To Ubound(p)
        
        Var col=Cptr(Ubyte Ptr,@p(n).col)
        Dim As Single dt=dot(p(n).norm,lightsource)
        Var dtt=map(1,-1,dt,.1,1)
        Dim As Ulong clr=Rgb(dtt*col[2],dtt*col[1],dtt*col[0])
        fill(p(n).p(),clr)
    Next n
End Sub

Sub sort(p() As triangle)
    For n1 As Long =Lbound(p) To Ubound(p)-1
        For n2 As Long=n1+1 To Ubound(p)
            If p(n1).ctr.z<p(n2).ctr.z Then Swap p(n1),p(n2)
        Next n2
    Next n1
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
    Static As Double timervalue,lastsleeptime,t3,frames
    frames+=1
    If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

Sub setcolours(colours() As Ulong,colour As Ulong=Rgb(100,255,0))
    For n As Long=1 To 20
        colours(n)=Rgb(0,255,0)
    Next n
End Sub

Function rainbow( x As Single ) As Ulong 'idea from bluatigro
    Static As Double pi=4*Atn(1)
    #define rad(n) (pi/180)*(n)
    Dim As Ulong r , g , b
    r = Sin( rad( x ) ) * 127 + 128
    g = Sin( rad( x - 120 ) ) * 127 + 128
    b = Sin( rad( x + 120 ) ) * 127 + 128
    Return Rgb( r And 255 , g And 255 , b And 255 )
End Function

'===============================================================================
Dim As pt d(1 To 12)={ _
(0.000000,-0.525731,0.850651), _
(0.850651,0.000000,0.525731), _
(0.850651,0.000000,-0.525731), _
(-0.850651,0.000000,-0.525731), _
(-0.850651,0.000000,0.525731), _
(-0.525731,0.850651,0.000000), _
(0.525731,0.850651,0.000000), _
(0.525731,-0.850651,0.000000), _
(-0.525731,-0.850651,0.000000), _
(0.000000,-0.525731,-0.850651), _
(0.000000,0.525731,-0.850651), _
(0.000000,0.525731,0.850651)}


Dim As Ulong colours(1 To 20)
Dim As triangle p(1 To 20),rot(1 To 20),shade(1 To 20)
blow(d(),Type(1024\2,768\2,0),200)
setcolours(colours())
setup(p(),d(),colours())

Dim  As Angle3D A3d
Dim As pt ang
Dim As pt c=Type(1024\2,768\2,0)
Dim As Long fps,flag,mx,my,btn
Screen 20,32,,64
Dim As Any Ptr i=Imagecreate(1024,768)
For x As Long=0 To 1023
    For y As Long=0 To 767
        Pset i,(x,y),rainbow(Sqr((x+50)^2+(y+50)^2))
    Next
Next
windowtitle "Click for colour"
Do
    ang.x+=.03/2  'the orbiting speed
    ang.y+=.02/2
    ang.z+=.01/2
    Getmouse(mx,my,,btn)
    If btn And flag=0 And Point(mx,my)<>rgb(255,255,255)  Then
        flag=1
        setcolours(colours(),Point(mx,my))
        For n As Long=1 To 20
            p(n).col=Point(mx,my)
        Next n
    End If
    
    A3D=Angle3D.construct(ang.x,ang.y,ang.z)
    For n As Long=1 To 20
        For m As Long=0 To 2
            shade(n).p(m)=Rotate(c,p(n).p(m),A3D,Type(.8,.8,.8))
            rot(n).p(m)=Rotate(c,p(n).p(m),A3D)
            shade(n).p(m)=perspective(shade(n).p(m),Type(1024\2,768\2,2000))
            rot(n).p(m)=perspective(rot(n).p(m),Type(1024\2,768\2,2000))
        Next m
        shade(n).ctr=Rotate(c,p(n).ctr,A3D,Type(.8,.8,.8))
        rot(n).ctr=Rotate(c,p(n).ctr,A3D)
        rot(n).norm=Type(rot(n).ctr.x-c.x,rot(n).ctr.y-c.y,rot(n).ctr.z)
        rot(n).col=p(n).col
    Next n
    
    sort(rot())
    
    Screenlock
    Cls
    Circle(200,100),20,Rgb(100,255,0),,,,f
    Circle(500,100),20,Rgb(255,100,0),,,,f
    Circle(800,100),20,Rgb(0,100,255),,,,f
    Put(0,0),i,Pset
    Draw String(20,20),"framerate = " &fps
    shadow(shade())
    show(rot())
    Screenunlock
    Sleep regulate(65,fps)
    flag=btn
Loop Until Len(Inkey)

Sleep
imagedestroy(i)
triangles:
Data _
2,3, 7, _
2, 8, 3, _
4, 5, 6, _
5, 4, 9, _
7, 6, 12, _
6, 7, 11, _
10, 11, 3, _
11, 10, 4, _
8, 9, 10, _
9, 8, 1, _
12, 1, 2, _
1, 12, 5, _
7, 3, 11, _
2, 7, 12, _
4, 6, 11, _
6, 5, 12, _
3, 8, 10, _
8, 2, 1, _
4, 10, 9, _
5, 9, 1



 

[Dr_D]

Nice. :)

[UEZ]

Very nice dodicat. I personally don't like rainbow colors but great idea to change the color picking from the rainbow.

Thanks for sharing.

[D.J.Peters]

Code: Select all

#include "GL/gl.bi"
type Vector3f
  declare constructor(x as single=0, _
                      y as single=0, _
                      z as single=0)
  declare operator cast as single ptr
  as single x,y,z
end type
constructor Vector3f(a as single, b as single, c as single)
  x=a : y=b : z=c
end constructor
operator Vector3f . cast as single ptr : return @x : end operator
operator -(a as Vector3f,b as vector3f) as Vector3f 
  return Vector3f(a.x-b.x,a.y-b.y,a.z-b.z)
end operator
operator +(a as Vector3f,b as vector3f) as Vector3f
  return Vector3f(a.x+b.x,a.y+b.y,a.z+b.z)
end operator
operator *(a as Vector3f,b as single) as Vector3f
  return Vector3f(a.x*b,a.y*b,a.z*b)
end operator
' dot product
operator *(a as Vector3f,b as vector3f) as single
  return a.x*b.x + a.y*b.y + a.z*b.z
end operator
' cross product
operator \(a as Vector3f,b as vector3f) as Vector3f
  return Vector3f(a.y*b.z - a.z*b.y, _
                  a.z*b.x - a.x*b.z, _
                  a.x*b.y - a.y*b.x)
end operator
function normalize(a as Vector3f) as Vector3f 
  dim as single l=1.0/sqr(a*a)
  return Vector3f(a.x*l,a.y*l,a.z*l)
end function  
function TriangleNormal(a as Vector3f,b as Vector3f,c as Vector3f) as Vector3f
  return normalize((b-a)\(c-a)) 
end function  
function compileIcosahedron() as long
  static as Vector3f ver(...) => { _
  Vector3f( 0.000000,-0.525731, 0.850651), _
  Vector3f( 0.850651, 0.000000, 0.525731), _
  Vector3f( 0.850651, 0.000000,-0.525731), _
  Vector3f(-0.850651, 0.000000,-0.525731), _
  Vector3f(-0.850651, 0.000000, 0.525731), _
  Vector3f(-0.525731, 0.850651, 0.000000), _
  Vector3f( 0.525731, 0.850651, 0.000000), _
  Vector3f( 0.525731,-0.850651, 0.000000), _
  Vector3f(-0.525731,-0.850651, 0.000000), _
  Vector3f( 0.000000,-0.525731,-0.850651), _
  Vector3f( 0.000000, 0.525731,-0.850651), _
  Vector3f( 0.000000, 0.525731, 0.850651) }
  static as integer ind(...) => { _
   1,2, 6,  1, 7, 2,  3, 4, 5, 4, 3, 8, 6,5,11, _
   5,6,10,  9,10, 2, 10, 9, 3, 7, 8, 9, 8,7, 0, _
  11,0, 1,  0,11, 4,  6, 2,10, 1, 6,11, 3,5,10, _
   5,4,11,  2, 7, 9,  7, 1, 0, 3, 9, 8, 4,8, 0}
  static as ulong list=0
  if list<>0 then return list
  list = glGenLists(1)
  glNewList(list, GL_COMPILE)
    'glScalef(5,5,5)
    glBegin(GL_TRIANGLES)
    dim as integer i
    for i as integer = 0 to ubound(ind) step 3
      var a = ver(ind(i))
      var b = ver(ind(i+1))
      var c = ver(ind(i+2))
      var n = TriangleNormal(a,b,c)
      glColor3f(0.2,0.8,0.2)
      glNormal3fv(n) 
      glVertex3fv(a)
      glVertex3fv(b)
      glVertex3fv(c)
    next
    glEnd()
  glEndList()
  return list
end function

sub initOpenGL(w as long=-1, h as long=-1)
  if w<=0 orelse h<=0 then screeninfo w,h : w*=0.75:h*=0.75
  screenres w,h,32,,2
  glEnable(GL_DEPTH_TEST)
  glEnable(GL_CULL_FACE)
  glEnable(GL_LIGHTING)
  glEnable(GL_LIGHT0)
  'glEnable(GL_AUTO_NORMAL)
  glEnable(GL_COLOR_MATERIAL)
  glMatrixMode(GL_PROJECTION)
  glLoadIdentity()
  glFrustum(-w/h, w/h, -1, 1, 1, 100)
  glMatrixMode(GL_MODELVIEW)
end sub
' main
InitOpenGL(512,512)
dim as ulong Icosahedron = compileIcosahedron()
dim as single p(3) => {10,10,10,1}
dim as Vector3f rot
glLightfv(GL_LIGHT0,GL_POSITION,@p(0))
while inkey()=""
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT)
  glPushMatrix()
    glLightfv(GL_LIGHT0,GL_POSITION,@p(0))
    glTranslatef(0,0, -2)
    glRotatef(rot.x,1,0,0)
    glRotatef(rot.y,0,1,0)
    glRotatef(rot.z,0,0,1)
    glCallList(Icosahedron)
  glPopMatrix()
  flip : sleep 10
  rot = rot+Vector3f(.5,1,2)
wend

[dodicat]

For basiccoder2 (who's post has gone), but referring to
https://www.mathsisfun.com/geometry/icosahedron.html
And using the property that an opengl screen can use win api child windows (which saves using gdi to draw things), and simulating some of the link.
Windows only for this:

Code: Select all

#include "windows.bi"
#include "GL/gl.bi"
Sub setupgl
      Dim As Integer xres,yres
      Screeninfo xres,yres
      glDisable (GL_DEPTH_TEST)
      glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA)
      glEnable (GL_BLEND)
      glEnable (GL_LINE_SMOOTH)
      glOrtho 0, xres, yres,0,-1, 1
      glclearcolor 1,1,1,1
End Sub
Screen 20,32,,2
setupgl
Dim Shared As Long wire,solid,glass

Type pt
      As Double x,y,z
End Type

Type triangle
      As pt p(0 To 2)
      As pt ctr
      As Ulong col
      As pt norm
End Type

Type angle3D             'FLOATS for angles
      As Single sx,sy,sz
      As Single cx,cy,cz
      Declare Static Function construct(As Single,As Single,As Single) As Angle3D
End Type

Function Angle3D.construct(x As Single,y As Single,z As Single) As Angle3D
      Return   Type (Sin(x),Sin(y),Sin(z), _
      Cos(x),Cos(y),Cos(z))
End Function

Function Rotate(c As pt,p As pt,a As Angle3D,scale As pt=Type(1,1,1)) As pt
      Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
      Return Type<pt>((scale.x)*((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.y)*((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.z)*((-a.sy)*dx+(a.sx*a.cy)*dy+(a.cx*a.cy)*dz)+c.z)
End Function

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

Function dot(p As pt,v2 As Pt) As Single 'dot product |v1| * |v2| *cos(angle between v1 and v2)
      Dim As Single d1=Sqr(p.x*p.x + p.y*p.y+ p.z*p.z),d2=Sqr(v2.x*v2.x + v2.y*v2.y +v2.z*v2.z)
      Dim As Single v1x=p.x/d1,v1y=p.y/d1,v1z=p.z/d1 'normalize
      Dim As Single v2x=v2.x/d2,v2y=v2.y/d2,v2z=v2.z/d2 'normalize
      Return (v1x*v2x+v1y*v2y+v1z*v2z)
End Function

Sub drawpolygon(p() As pt, c As Ulong) 
      Var col=Cptr(Ubyte Ptr,@c)
      glcolor4ub(col[2],col[1],col[0],255)
      Dim k As Long=Ubound(p)+1
      Dim As Long index,nextindex
      For n As Long=Lbound(p) To Ubound(p)
            index=n Mod k:nextindex=(n+1) Mod k
            If nextindex=0 Then nextindex=Lbound(p)
            glvertex2d(p(index).x,p(index).y)
            glvertex2d(p(nextindex).x,p(nextindex).y)
      Next
End Sub


Sub fill(p() As Pt,c As Ulong,im As Any Ptr=0,flag As Long)
      Var col=Cptr(Ubyte Ptr,@c)
      glcolor4ub(col[2],col[1],col[0],150)
      If glass Then glcolor4ub(0,0,50,55)
      glbegin gl_lines
      #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
            If wire=0 Or glass=1 Then
                  glvertex2d(xi(i)+1,y)
                  glvertex2d(xi(i+1)+1-1,y)
            End If
      Next i
Next y
If wire=1 Then
      drawpolygon(p(),Rgb(0,0,0))
Else
      If flag =0 And solid=0 Then  drawpolygon(p(),Rgb(255,255,255))
End If
glend
End Sub

Sub blow(d() As pt,t As pt,m As Double)
      For n As Long=1 To 12
            d(n).x=(d(n).x)*m+t.x
            d(n).y=(d(n).y)*m+t.y
            d(n).z=(d(n).z)*m+t.z
      Next
End Sub

Sub setup(p() As triangle,d() As pt,colours() As Ulong)
      Dim As Long i
      Dim As Double cx,cy,cz
      Dim As pt centre=Type(1024\2,768\2,0)
      For n As Long=1 To 20
            cx=0:cy=0:cz=0
            For k As Long=0 To 2
                  Read i
                  p(n).p(k)=d(i)
                  cx+=d(i).x
                  cy+=d(i).y
                  cz+=d(i).z
            Next k
            p(n).ctr=Type(cx/3,cy/3,cz/3)
            p(n).norm=Type(p(n).ctr.x-centre.x,p(n).ctr.y-centre.y,p(n).ctr.z-centre.z)
            p(n).col=colours(n)
      Next n
      
End Sub


Sub show(p() As triangle)
      #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
      Dim As Long flag
      Dim As pt lightsource
      lightsource=Type(.5,0,.5)
      For n As Long=Lbound(p) To Ubound(p)
            If n<=10 Then flag=1 Else flag=0
            Var col=Cptr(Ubyte Ptr,@p(n).col)
            Dim As Single dt=dot(p(n).norm,lightsource)
            Var dtt=map(1,-1,dt,.1,1)
            Dim As Ulong clr=Rgba(dtt*col[2],dtt*col[1],dtt*col[0],150)
            fill(p(n).p(),clr,0,flag)
      Next n
End Sub

Sub sort(p() As triangle)
      For n1 As Long =Lbound(p) To Ubound(p)-1
            For n2 As Long=n1+1 To Ubound(p)
                  If p(n1).ctr.z<p(n2).ctr.z Then Swap p(n1),p(n2)
            Next n2
      Next n1
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
      Static As Double timervalue,_lastsleeptime,t3,frames
      frames+=1
      If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
      Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
      If sleeptime<1 Then sleeptime=1
      _lastsleeptime=sleeptime
      timervalue=Timer
      Return sleeptime
End Function

Sub setcolours(colours() As Ulong,colour As Ulong=Rgb(100,255,0))
      Randomize 2
      For n As Long=1 To 20
            colours(n)=Rgba(Rnd*255,Rnd*255,Rnd*255,15)
      Next n
End Sub


Function Set_Font (Font As String,Size As Long,Bold As Long,Italic As Long,Underline As Long,StrikeThru As Long) As HFONT
      Dim As HDC hDC=GetDC(HWND_DESKTOP)
      Dim As Long CyPixels=GetDeviceCaps(hDC,LOGPIXELSY)
      ReleaseDC(HWND_DESKTOP,hDC)
      Return CreateFont(0-(Size*CyPixels)/72,0,0,0,Bold,Italic,Underline,StrikeThru,ANSI_CHARSET _
      ,OUT_TT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,FF_DONTCARE,Font)
End Function


'===============================================================================
Dim As pt d(1 To 12)={ _
(0.000000,-0.525731,0.850651), _
(0.850651,0.000000,0.525731), _
(0.850651,0.000000,-0.525731), _
(-0.850651,0.000000,-0.525731), _
(-0.850651,0.000000,0.525731), _
(-0.525731,0.850651,0.000000), _
(0.525731,0.850651,0.000000), _
(0.525731,-0.850651,0.000000), _
(-0.525731,-0.850651,0.000000), _
(0.000000,-0.525731,-0.850651), _
(0.000000,0.525731,-0.850651), _
(0.000000,0.525731,0.850651)}

Dim As Ulong colours(1 To 20)
Dim As triangle p(1 To 20),rot(1 To 20)
blow(d(),Type(1024\2,768\2,0),200)
setcolours(colours())
setup(p(),d(),colours())

Dim  As Angle3D A3d
Dim As pt ang
Dim As pt c=Type(1024\2,768\2,0)
Dim As Long mx,my,btn
Color ,Rgb(255,255,255)

Dim Win As Any Ptr

Screencontrol 2, *Cptr(Integer Ptr,@Win )
Dim Shared As HFONT  ThisFont:ThisFont=Set_Font("Times new roman",16,0,0,0,0)
Var Cc=CreateWindowEx(0,"button","alpha", WS_VISIBLE Or WS_CHILD,0,0,70,30,win,0,0,0)
Var Dd=CreateWindowEx(0,"Button","solid", WS_VISIBLE Or WS_CHILD,70,0,70,30,win,0,0,0)
Var c1=CreateWindowEx(0,"STATIC","", WS_VISIBLE Or WS_CHILD ,150,650,300,40,win,0,0,0)
Var Ee=CreateWindowEx(0,"Button","wire",WS_BORDER Or WS_VISIBLE Or WS_CHILD,140,0,70,30,win,0,0,0)
Var Gg=CreateWindowEx(0,"Button","glass",WS_BORDER Or WS_VISIBLE Or WS_CHILD,210,0,70,30,win,0,0,0)
SendMessage(Cc,WM_SETFONT,Cast(WPARAM,ThisFont),0)
SendMessage(Dd,WM_SETFONT,Cast(WPARAM,ThisFont),0)
SendMessage(Ee,WM_SETFONT,Cast(WPARAM,ThisFont),0)
SendMessage(Gg,WM_SETFONT,Cast(WPARAM,ThisFont),0)
ThisFont=Set_Font("Times new roman",26,0,0,0,0)
SendMessage(C1,WM_SETFONT,Cast(WPARAM,ThisFont),0)
Dim As msg msg
Dim As Long flag,fps
While true
      While (PeekMessage (@Msg, NULL, 0, 0, PM_REMOVE) > 0)
            TranslateMessage (@Msg)
            DispatchMessage (@Msg)
            Select Case msg.hwnd
            Case Cc 'alpha
                  Select Case msg.message
                  
                  Case WM_LBUTTONDOWN
                        wire=0
                        solid=0
                        glass=0
                        glEnable (GL_BLEND)
                  End Select
                  
            Case Dd 'solid
                  Select Case msg.message
                  Case WM_LBUTTONDOWN
                        wire=0
                        solid=1
                        glass=0
                        gldisable (GL_BLEND)
                  End Select 
                  
            Case Ee
                  Select Case msg.message
                  Case WM_LBUTTONDOWN
                        wire=1
                        solid=0
                        glass=0
                  End Select
                  
            Case Gg 'glass
                  Select Case msg.message
                  Case WM_LBUTTONDOWN
                        wire=1
                        'solid=1
                        glass=1
                        glEnable (GL_BLEND)
                  End Select
                  
            Case Else
                  
                  setwindowtext(C1,"framerate = "+Str(fps))   
                  
            End Select
            
            
            
            If Inkey=Chr(255)+"k" Then End
      Wend
      ang.x+=.03/2  'the orbiting speed
      ang.y+=.02/2
      ang.z+=.01/2
      'Getmouse(mx,my,,btn)
      'If btn And flag=0 And Point(mx,my)<>Rgb(255,255,255)  Then
      'flag=1
      'For n As Long=1 To 20
      'p(n).col=Point(mx,my)
      ' Next n
      ' End If
      A3D=Angle3D.construct(ang.x,ang.y,ang.z)
      For n As Long=1 To 20
            For m As Long=0 To 2
                  rot(n).p(m)=Rotate(c,p(n).p(m),A3D)
                  rot(n).p(m)=perspective(rot(n).p(m),Type(1024\2,768\2,2000))
            Next m
            rot(n).ctr=Rotate(c,p(n).ctr,A3D)
            rot(n).norm=Type(rot(n).ctr.x-c.x,rot(n).ctr.y-c.y,rot(n).ctr.z)
            rot(n).col=p(n).col
      Next n
      
      sort(rot())
      
      
      glClear(GL_COLOR_BUFFER_BIT)
      show(rot())
      Flip
      Sleep regulate(60,fps),1
      'flag=btn
Wend

triangles:
Data _
2,3, 7, _
2, 8, 3, _
4, 5, 6, _
5, 4, 9, _
7, 6, 12, _
6, 7, 11, _
10, 11, 3, _
11, 10, 4, _
8, 9, 10, _
9, 8, 1, _
12, 1, 2, _
1, 12, 5, _
7, 3, 11, _
2, 7, 12, _
4, 6, 11, _
6, 5, 12, _
3, 8, 10, _
8, 2, 1, _
4, 10, 9, _
5, 9, 1



 

[BasicCoder2]

@dodicat

For basiccoder2 (who's post has gone),

Yes, sorry dodicat. It wasn't really for me, it was a challenge for anyone to show what FreeBASIC can do. I am not able to make my own 3d demos like that or offer anything of interest to others so now I only lurk here on occasion for old times sake.

[dodicat]

Nothing wrong with auld lang syne basiccoder2.
You have made many neat 3d contributions (your isometric things for example which add game speed to 3D).
It's just that I use a template of sorts for these solid shapes, I am working up to the disco ball.

[Dr_D]

Nothing wrong with auld lang syne basiccoder2.
You have made many neat 3d contributions (your isometric things for example which add game speed to 3D).
It's just that I use a template of sorts for these solid shapes, I am working up to the disco ball.

Agreed. :)

[badidea]

I am working up to the disco ball.

The disco ball is mathematically impossible. But there are enough other polyhedra.
If you however do succeed in making a disco ball, will you add lights and reflections as well?

[dodicat]

I find the disco ball falling into mathematical order after a few drinks.
Alles klar then.
My polyhedra so far are all lit, except for the wire and glass icosahedrons, so the disco ball will be lit from a single source when it is ready.
Thanks for testing badidea.

[UEZ]

I find the disco ball falling into mathematical order after a few drinks.
Alles klar then.

LOL

Here a very simple version of a disco ball in greyscale:

Code: Select all

''by UEZ
#Include "fbgfx.bi"
Using FB

#Define Min(a, b)		(Iif(a < b, a, b))
#Define Max(a, b)		(Iif(a > b, a, b))
#Define Col(c)			Max(0, Min(255, c))
#Define w 				(1920 Shr 1)
#Define h 				(1080 Shr 1)
#Define w2 				(w Shr 1)
#Define h2 				(h Shr 1)
#Define _t  			(1 / 60)

Screenres w, h, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP
Screenset 1, 0
Color &hFF, &hFF000000

Dim As Long imgData, pitch
Dim As Any Ptr pScrn
ScreenInfo , , , imgData, pitch
pScrn = Screenptr()
#Define PixelSetScrn(_x, _y, colour)		*Cptr(Ulong Ptr, pScrn + (_y) * pitch + (_x) * imgData) = (colour)


Dim As Ulong iFPS, cfps = 0
Dim As Double t = 0, fTimer = Timer
Dim As Ulong c
Dim As Long m, ww = 900, ww2 = ww * ww, py, w2w = ww Shr 1
Dim As Single px, e, o, x, y, sy, f1, f2

Do
	Cls
	Line (w2 - 5, 0) - (w2 + 5, 118), &hF0808080, BF
	m = ww2
	While m
		x = -2.15 + 4 * (m Mod ww) / ww
		y = 1.40 - 4 * m / ww2
		e = (x * x + y * y)
		px = m Mod ww
		py = m \ ww
		o = (3 - Sqr(4 - 5 * e)) / (e + 1)
		f1 = o * ww
		f2 = t * w2w
		sy = (x * f1 + f2 And ww Xor y * f1 And ww) / ww
		If sy > 0 Then 
			c = Col(sy * 255)
			PixelSetScrn(Cint(px), Cint(py), Rgb(c, c, c))
		Endif
		m -= 1
	Wend
	
	t += _t

	Draw String(4, 4), iFPS & " fps", &hFFFFFFFF

	Flip
	
	cfps += 1
	If Timer - fTimer > 0.99 Then
		iFPS = cfps
		cfps = 0
		fTimer = Timer
	End If
	Sleep (1)
Loop Until Len(Inkey())

[BasicCoder2]

It's just that I use a template of sorts for these solid shapes, I am working up to the disco ball.

Now that will be a challenge!!
Here is one that looks good for inspiration. Uses mouse to rotate and resize.
https://sketchfab.com/3d-models/disco-m ... 49c8f22b6c

[badidea]

Those are fake disco balls. The size of the small mirrors should be the same everywhere.

[dodicat]

Thanks UEZ, that looks pretty good.
Thanks BasicCoder2, that's one idea.
Badidea, you are correct that shapes should fit, whether they should all be the same shape, or say triangles+pentagons for example.