Source code in the basic programming language

clg
color white
rect 0,0,graphwidth, graphheight
for n = 1 to 100
	color rgb(2*n,2*n,2*n)
	circle 150-2*n/3,150-n/2,150-n
next n

      MODE 8
      INSTALL @lib$+"D3DLIB"
      D3DTS_VIEW = 2
      D3DTS_PROJECTION = 3
      D3DRS_SPECULARENABLE = 29
      
      SYS "LoadLibrary", @lib$+"D3DX8BBC.DLL" TO d3dx%
      IF d3dx%=0 ERROR 100, "Couldn't load D3DX8BBC.DLL"
      SYS "GetProcAddress", d3dx%, "D3DXCreateSphere" TO `D3DXCreateSphere`
      SYS "GetProcAddress", d3dx%, "D3DXMatrixLookAtLH" TO `D3DXMatrixLookAtLH`
      SYS "GetProcAddress", d3dx%, "D3DXMatrixPerspectiveFovLH" TO `D3DXMatrixPerspectiveFovLH`
      
      DIM eyepos%(2), lookat%(2), up%(2), mat%(3,3)
      
      DIM D3Dlight8{Type%, Diffuse{r%,g%,b%,a%}, Specular{r%,g%,b%,a%}, \
      \ Ambient{r%,g%,b%,a%}, Position{x%,y%,z%}, Direction{x%,y%,z%}, \
      \ Range%, Falloff%, Attenuation0%, Attenuation1%, Attenuation2%, \
      \ Theta%, Phi%}
      
      DIM D3Dmaterial8{Diffuse{r%,g%,b%,a%}, Ambient{r%,g%,b%,a%}, \
      \ Specular{r%,g%,b%,a%}, Emissive{r%,g%,b%,a%}, Power%}
      
      DIM D3Dbasemesh8{QueryInterface%, Addref%, Release%, \
      \ DrawSubset%, GetNumFaces%, GetNumVertices%, GetFVF%, \
      \ GetDeclaration%, GetOptions%, GetDevice%, \
      \ CloneMeshFVF%, CloneMesh%, GetVertexBuffer%, GetIndexBuffer%, \
      \ LockVertexBuffer%, UnlockVertexBuffer%, LockIndexBuffer%, \
      \ UnlockIndexBuffer%, GetAttributeTable%}
      
      DIM D3Ddevice8{QueryInterface%, AddRef%, Release%, TestCooperativeLevel%, \
      \ GetAvailableTextureMem%, ResourceManagerDiscardBytes%, GetDirect3D%, \
      \ GetDeviceCaps%, GetDisplayMode%, GetCreationParameters%, SetCursorProperties%, \
      \ SetCursorPosition%, ShowCursor%, CreateAdditionalSwapChain%, Reset%, \
      \ Present%, GetBackBuffer%, GetRasterStatus%, SetGammaRamp%, GetGammaRamp%, \
      \ CreateTexture%, CreateVolumeTexture%, CreateCubeTexture%, CreateVertexBuffer%, \
      \ CreateIndexBuffer%, CreateRenderTarget%, CreateDepthStencilSurface%, \
      \ CreateImageSurface%, CopyRects%, UpdateTexture%, GetFrontBuffer%, \
      \ SetRenderTarget%, GetRenderTarget%, GetDepthStencilSurface%, BeginScene%, \
      \ EndScene%, Clear%, SetTransform%, GetTransform%, MultiplyTransform%, \
      \ SetViewport%, GetViewport%, SetMaterial%, GetMaterial%, SetLight%, GetLight%, \
      \ LightEnable%, GetLightEnable%, SetClipPlane%, GetClipPlane%, SetRenderState%, \
      \ GetRenderState%, BeginStateBlock%, EndStateBlock%, ApplyStateBlock%, \
      \ CaptureStateBlock%, DeleteStateBlock%, CreateStateBlock%, SetClipStatus%, \
      \ GetClipStatus%, GetTexture%, SetTexture%, GetTextureStageState%, \
      \ SetTextureStageState%, ValidateDevice%, GetInfo%, SetPaletteEntries%, \
      \ GetPaletteEntries%, SetCurrentTexturePalette%, GetCurrentTexturePalette%, \
      \ DrawPrimitive%, DrawIndexedPrimitive%, DrawPrimitiveUP%, \
      \ DrawIndexedPrimitiveUP%, ProcessVertices%, CreateVertexShader%, \
      \ SetVertexShader%, GetVertexShader%, DeleteVertexShader%, \
      \ SetVertexShaderConstant%, GetVertexShaderConstant%, GetVertexShaderDeclaration%, \
      \ GetVertexShaderFunction%, SetStreamSource%, GetStreamSource%, SetIndices%, \
      \ GetIndices%, CreatePixelShader%, SetPixelShader%, GetPixelShader%, \
      \ DeletePixelShader%, SetPixelShaderConstant%, GetPixelShaderConstant%, \
      \ GetPixelShaderFunction%, DrawRectPatch%, DrawTriPatch%, DeletePatch%}
      
      pDevice%=FN_initd3d(@hwnd%, 1, 1)
      IF pDevice%=0 ERROR 100, "Couldn't create Direct3D8 device"
      !(^D3Ddevice8{}+4) = !pDevice%
      
      SYS `D3DXCreateSphere`, pDevice%, FN_f4(1), 50, 50, ^meshSphere%, 0
      IF meshSphere% = 0 ERROR 100, "D3DXCreateSphere failed"
      !(^D3Dbasemesh8{}+4) = !meshSphere%
      
      REM. Point-source light:
      D3Dlight8.Type%=1 : REM. point source
      D3Dlight8.Diffuse.r%  = FN_f4(1)
      D3Dlight8.Diffuse.g%  = FN_f4(1)
      D3Dlight8.Diffuse.b%  = FN_f4(1)
      D3Dlight8.Specular.r% = FN_f4(1)
      D3Dlight8.Specular.g% = FN_f4(1)
      D3Dlight8.Specular.b% = FN_f4(1)
      D3Dlight8.Position.x% = FN_f4(2)
      D3Dlight8.Position.y% = FN_f4(1)
      D3Dlight8.Position.z% = FN_f4(4)
      D3Dlight8.Range%      = FN_f4(10)
      D3Dlight8.Attenuation0% = FN_f4(1)
      
      REM. Material:
      D3Dmaterial8.Diffuse.r%  = FN_f4(0.2)
      D3Dmaterial8.Diffuse.g%  = FN_f4(0.6)
      D3Dmaterial8.Diffuse.b%  = FN_f4(1.0)
      D3Dmaterial8.Specular.r% = FN_f4(0.4)
      D3Dmaterial8.Specular.g% = FN_f4(0.4)
      D3Dmaterial8.Specular.b% = FN_f4(0.4)
      D3Dmaterial8.Power%      = FN_f4(100)
      
      fovy = RAD(30)
      aspect = 5/4
      znear = 1
      zfar = 1000
      bkgnd% = &7F7F7F
      eyepos%() = 0, 0, FN_f4(6)
      lookat%() = 0, 0, 0
      up%() = 0, FN_f4(1), 0
      
      SYS D3Ddevice8.Clear%, pDevice%, 0, 0, 3, bkgnd%, FN_f4(1), 0
      SYS D3Ddevice8.BeginScene%, pDevice%
      SYS D3Ddevice8.SetLight%, pDevice%, 0, D3Dlight8{}
      SYS D3Ddevice8.LightEnable%, pDevice%, 0, 1
      SYS D3Ddevice8.SetMaterial%, pDevice%, D3Dmaterial8{}
      SYS D3Ddevice8.SetRenderState%, pDevice%, D3DRS_SPECULARENABLE, 1
      
      SYS `D3DXMatrixLookAtLH`, ^mat%(0,0), ^eyepos%(0), ^lookat%(0), ^up%(0)
      SYS D3Ddevice8.SetTransform%, pDevice%, D3DTS_VIEW, ^mat%(0,0)
      
      SYS `D3DXMatrixPerspectiveFovLH`, ^mat%(0,0), FN_f4(fovy), \
      \                                 FN_f4(aspect), FN_f4(znear), FN_f4(zfar)
      SYS D3Ddevice8.SetTransform%, pDevice%, D3DTS_PROJECTION, ^mat%(0,0)
      
      SYS D3Dbasemesh8.DrawSubset%, meshSphere%, 0
      SYS D3Ddevice8.EndScene%, pDevice%
      SYS D3Ddevice8.Present%, pDevice%, 0, 0, 0, 0
      
      SYS D3Ddevice8.Release%, pDevice%
      SYS D3Dbasemesh8.Release%, meshSphere%
      SYS "FreeLibrary", d3dx%
      END


MAKE OBJECT SPHERE 1,1

' "\" = a integer division (CPU) 
' "/" = a floating point division (FPU)
' the compiler takes care of the conversion between floating point and integer
' compile with: FBC -s console "filename.bas" or FBC -s GUI "filename.bas"
' filename is whatever name you give it, .bas is mandatory

' Sphere using XPL0 code from rosetacode sphere page
' Altered freebasic version to compile in default mode
' version 17-06-2015
' compile with: fbc -s console or fbc -s gui
#Define W 640
#Define H 480

ScreenRes W, H, 32   ' set 640x480x32 graphics mode, 32 bits color mode
WindowTitle "32 bpp Cyan Sphere FreeBASIC"

' wait until keypress
' Color(RGB(255,255,255),RGB(0,0,0))         ' default white foreground, black background 
Locate 50,2
Print "Enter any key to start"
Sleep

Dim As UInteger R = 100, R2 = R * R          ' radius, in pixels; radius squared
Dim As UInteger X0 = W \ 2, Y0 = H \ 2       ' coordinates of center of screen
Dim As Integer X, Y, C, D2                   ' coords, color, distance from center squared
   
For Y = -R To R                              ' for all the coordinates near the circle
  For X = -R To R                            ' which is under the sphere
    D2 = X * X + Y * Y 
    If D2 <= R2 Then                         ' coordinate is inside circle under sphere
                                             ' height of point on surface of sphere above X,Y
      C = Sqr(R2 - D2) - ( X + Y) / 2 + 130  ' color is proportional; offset X and Y, and

      Color C Shl 8 + C                      ' = color RGB(0, C, C)
                                             ' green + blue = cyan
      PSet(X + X0, Y + Y0)
    End If
  Next 
Next 

' wait until keypress
Locate 50,2
Color(RGB(255,255,255),RGB(0,0,0))           ' foreground color is changed
' empty keyboard buffer 
While InKey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End

'Sphere for FreeBASIC May 2015
'spherefb4.bas
'Sphere using XPL0 code from rosetacode sphere page
'
screenres 640,480,32   '\set 640x480x32 graphics mode
windowtitle "32 bpp Blue Sphere FreeBASIC"
'
' wait until keypress
locate 50,2
color(rgb(255,255,255),rgb(0,0,0)) 
Print "Enter any key to start" 
sleep
 R=100 : R2=R*R	               '\radius, in pixels; radius squared
 X0=640/2 : Y0=480/2           '\coordinates of center of screen
 dim as integer X, Y, Z, C, D2 '\coords, color, distance from center squared
'                             
for Y= -R to +R                '\for all the coordinates near the circle
    for X = -R to +R          '\ which is under the sphere
        D2 = X*X + Y*Y        '
        C = 0                  '\default color is black
        if D2 <= R2 then       '\coordinate is inside circle under sphere
            Z = sqr(R2-D2)     '\height of point on surface of sphere above X,Y
            C = Z-(X+Y)/2+130  ' \color is proportional; offset X and Y, and
        endif
         color c                ' \ shift color to upper limit of its range
                                '\green + blue = cyan orginal line don't understand
         Pset(X+X0, Y+Y0)
    next x
  next y
' 
' wait until keypress
locate 50,2
color(rgb(255,255,255),rgb(0,0,0)) 
Print "Enter any key to exit " 
sleep
END

WindowWidth  =420
WindowHeight =460

nomainwin

open "Sphere" for graphics_nsb_nf as #w

#w "down ; fill lightgray"

xS =200
yS =200
for radius =150 to 0 step -1
    level$ =str$( int( 256 -256 *radius /150))
    c$ =level$ +" " +level$ +" " +level$ 
    #w "color ";     c$
    #w "backcolor "; c$
    #w "place "; xS; " "; yS
    xS =xS -0.5
    yS =yS -0.2
    #w "circlefilled "; radius
next radius

#w "flush"
wait
close #w
end

10 MODE 2:s$=".:!*oe&#%@"
20 DIM v(2),vec(2)
30 v(0)=30:v(1)=30:v(2)=-50
40 lung=SQR(v(0)*v(0)+v(1)*v(1)+v(2)*v(2))
50 v(0)=v(0)/lung
60 v(1)=v(1)/lung
70 v(2)=v(2)/lung
80 r=10:k=2:ambient=0.4
90 FOR i=INT(-r) TO INT(r)
100 x=i+0.5
110 FOR j=INT(-2*r) TO INT(2*r)
120 y=j/2+0.5
130 IF (x*x+y*y<=r*r) THEN GOSUB 1000 ELSE PRINT" ";
140 NEXT j
150 PRINT
160 NEXT i
170 END
1000 vec(0)=x
1010 vec(1)=y
1020 vec(2)=SQR(r*r-x*x-y*y)
1030 GOSUB 2000
1040 GOSUB 3000
1050 b=d^k+ambient
1060 intensity%=(1-b)*(LEN(s$)-1)
1070 IF (intensity%<0) THEN intensity%=0
1080 IF (intensity%>LEN(s$)-1) THEN intensity%=LEN(s$)-2
1090 PRINT MID$(s$,intensity%+1,1);
1100 RETURN
2000 lung=SQR(vec(0)*vec(0)+vec(1)*vec(1)+vec(2)*vec(2))
2010 vec(0)=vec(0)/lung
2020 vec(1)=vec(1)/lung
2030 vec(2)=vec(2)/lung
2040 RETURN
3000 d=v(0)*vec(0)+v(1)*vec(1)+v(2)*vec(2)
3010 IF d<0 THEN d=-d ELSE d=0
3020 RETURN

; Original by Comtois @ 28/03/06
;
; Updated/Formated by Fluid Byte @ March.24,2009
;
; http://www.purebasic.fr/english/viewtopic.php?p=281258#p281258

Declare CreateSphere(M,P)
Declare UpdateMesh()

#_SIZEVERT = 36
#_SIZETRIS = 6
#FULLSCREEN = 0

Structure VECTOR
  X.f
  Y.f
  Z.f
EndStructure

Structure VERTEX
  X.f
  Y.f
  Z.f
  NX.f
  NY.f
  NZ.f
  Color.l
  U.f
  V.f
EndStructure

Structure TRIANGLE
  V1.w
  V2.w
  V3.w
EndStructure

Macro CALC_NORMALS
  *PtrV\NX = *PtrV\X
  *PtrV\NY = *PtrV\Y
  *PtrV\NZ = *PtrV\Z
EndMacro

Global *VBuffer, *IBuffer
Global Meridian = 50, Parallele = 50, PasLength = 4, Length

Define EventID, i, NbSommet, CameraMode, Angle.f, Pas.f = 0.5

InitEngine3D() : InitSprite() : InitKeyboard()

Add3DArchive(GetTemporaryDirectory(),#PB_3DArchive_FileSystem)
Add3DArchive(#PB_Compiler_Home + "Examples\Sources\Data\",#PB_3DArchive_FileSystem)

If #FULLSCREEN
  OpenScreen(800,600,32,"Sphere 3D")
Else
  OpenWindow(0,0,0,800,600,"Sphere 3D",#PB_Window_SystemMenu | 1)
  OpenWindowedScreen(WindowID(0),0,0,800,600,0,0,0)
EndIf

;-Texture
CreateImage(0,128,128)
StartDrawing(ImageOutput(0))
For i = 0 To 127 Step 4
  Box(0,i,ImageWidth(0),2,RGB(255,255,255))
  Box(0,i + 2,ImageWidth(0),2,RGB(0,0,155))
Next i
StopDrawing()
SaveImage(0,GetTemporaryDirectory() + "temp.bmp") : FreeImage(0)

;-Material
CreateMaterial(0,LoadTexture(0,"temp.bmp"))
RotateMaterial(0,0.1,#PB_Material_Animated)

;-Mesh
CreateSphere(Meridian,Parallele)

;-Entity
CreateEntity(0,MeshID(0),MaterialID(0))
ScaleEntity(0,60,60,60)

;-Camera
CreateCamera(0,0,0,100,100)
MoveCamera(0,0,0,-200)
CameraLookAt(0,EntityX(0),EntityY(0),EntityZ(0))

;-Light
AmbientColor(RGB(105, 105, 105))
CreateLight(0, RGB(255, 255,  55), EntityX(0) + 150, EntityY(0)      , EntityZ(0))
CreateLight(1, RGB( 55, 255, 255), EntityX(0) - 150, EntityY(0)      , EntityZ(0))
CreateLight(2, RGB( 55,  55, 255), EntityX(0)      , EntityY(0) + 150, EntityZ(0))
CreateLight(3, RGB(255,  55, 255), EntityX(0)      , EntityY(0) - 150, EntityZ(0))

; ----------------------------------------------------------------------------------------------------
; MAINLOOP
; ----------------------------------------------------------------------------------------------------

Repeat
  If #FULLSCREEN = 0
    Repeat
      EventID = WindowEvent()
      
      Select EventID
        Case #PB_Event_CloseWindow : End
      EndSelect
    Until EventID = 0
  EndIf
  
  Angle + Pas
  RotateEntity(0, Angle, Angle,Angle)
  
  If PasLength > 0 : UpdateMesh() : EndIf
  
  If ExamineKeyboard()
    If KeyboardReleased(#PB_Key_F1)
      CameraMode = 1 - CameraMode
      CameraRenderMode(0, CameraMode)
    EndIf
  EndIf
  
  RenderWorld()
  FlipBuffers()
Until KeyboardPushed(#PB_Key_Escape)

; ----------------------------------------------------------------------------------------------------
; FUNCTIONS
; ----------------------------------------------------------------------------------------------------

Procedure CreateSphere(M,P)
  ; M = Meridian
  ; P = Parallele
  ; The radius is 1. Front to remove it later, it's just for the demo.
  
  If M < 3 Or P < 2  : ProcedureReturn 0 : EndIf
  
  Protected Normale.VECTOR, NbSommet, i, j, Theta.f, cTheta.f, sTheta.f
  Protected Alpha.f, cAlpha.f, sAlpha.f, *PtrV.VERTEX, *PtrF.TRIANGLE, NbTriangle
  
  NbSommet = 2 + ((M + 1) * P)
  *VBuffer = AllocateMemory(#_SIZEVERT * Nbsommet)
  
  For i = 0 To M
    Theta  = i * #PI * 2.0 / M
    cTheta = Cos(theta)
    sTheta = Sin(theta)
    
    For j = 1 To P
      Alpha  = j * #PI / (P + 1)
      cAlpha = Cos(Alpha)
      sAlpha = Sin(Alpha)
      *PtrV = *VBuffer + #_SIZEVERT * ((i * P) + (j - 1))
      *PtrV\X = sAlpha * cTheta
      *PtrV\Y = sAlpha * sTheta
      *PtrV\Z = cAlpha
      *PtrV\U  = Theta / (2.0 * #PI)
      *PtrV\V  = Alpha / #PI
      CALC_NORMALS
    Next j
  Next i
  
  ; Southpole
  *PtrV = *VBuffer + #_SIZEVERT * ((M + 1) * P)   
  *PtrV\X =  0
  *PtrV\Y =  0   
  *PtrV\Z = -1
  *PtrV\U =  0
  *PtrV\V =  0
  CALC_NORMALS
  
  ; Northpole
  *PtrV + #_SIZEVERT
  *PtrV\X = 0
  *PtrV\Y = 0   
  *PtrV\Z = 1
  *PtrV\U = 0
  *PtrV\V = 0
  CALC_NORMALS
  
  ; Les facettes
  NbTriangle = 4 * M * P
  *IBuffer = AllocateMemory(#_SIZETRIS * NbTriangle)
  *PtrF = *IBuffer
  
  For i = 0 To M - 1
    For j = 1 To P - 1
      *PtrF\V1 = ((i + 1) * P) + j
      *PtrF\V2 = ((i + 1) * P) + (j - 1)
      *PtrF\V3 = (i * P) + (j - 1)
      *PtrF + #_SIZETRIS
      *PtrF\V3 = ((i + 1) * P) + j        ;Recto
      *PtrF\V2 = ((i + 1) * P) + (j - 1)  ;Recto
      *PtrF\V1 = (i * P) + (j - 1)        ;Recto
      *PtrF + #_SIZETRIS
      *PtrF\V1 = i * P + j
      *PtrF\V2 = ((i + 1) * P) + j
      *PtrF\V3 = (i * P) + (j - 1)
      *PtrF + #_SIZETRIS
      *PtrF\V3 = i * P + j               ;Recto
      *PtrF\V2 = ((i + 1) * P) + j       ;Recto
      *PtrF\V1 = (i * P) + (j - 1)       ;Recto
      *PtrF + #_SIZETRIS
    Next j     
  Next i
  
  ; The Poles
  For i = 0 To M - 1
    *PtrF\V3 = (M + 1) * P + 1
    *PtrF\V2 = (i + 1) * P
    *PtrF\V1 = i * P
    *PtrF + #_SIZETRIS
    *PtrF\V1 = (M + 1) * P + 1   ;Recto
    *PtrF\V2 = (i + 1) * P       ;Recto
    *PtrF\V3 = i * P             ;Recto
    *PtrF + #_SIZETRIS
  Next i     
  
  For i = 0 To M - 1
    *PtrF\V3 = (M + 1) * P
    *PtrF\V2 = i * P + (P - 1)
    *PtrF\V1 = (i + 1) * P + (P - 1)
    *PtrF + #_SIZETRIS
    *PtrF\V1 = (M + 1) * P              ;Recto
    *PtrF\V2 = i * P + (P - 1)          ;Recto
    *PtrF\V3 = (i + 1) * P + (P - 1)    ;Recto
    *PtrF + #_SIZETRIS 
  Next i     
  
  If CreateMesh(0,100)
    Protected Flag = #PB_Mesh_Vertex | #PB_Mesh_Normal | #PB_Mesh_UVCoordinate | #PB_Mesh_Color
    SetMeshData(0,Flag,*VBuffer,NbSommet)
    SetMeshData(0,#PB_Mesh_Face,*IBuffer,NbTriangle)
    ProcedureReturn 1
  EndIf
  
  ProcedureReturn 0
EndProcedure   

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure UpdateMesh()
  Protected NbTriangle = 4 * Meridian * Parallele
  
  Length + PasLength
  
  If Length >= NbTriangle
    PasLength = 0
    Length = Nbtriangle
  EndIf
  
  SetMeshData(0,#PB_Mesh_Face,*IBuffer,Length)
EndProcedure

SCREEN 13 ' enter high-color graphic mode

' sets palette colors B/N
FOR i = 0 TO 255
 PALETTE 255 - i, INT(i / 4) + INT(i / 4) * 256 + INT(i / 4) * 65536
NEXT i
PALETTE 0, 0

' draw the sphere
FOR i = 255 TO 0 STEP -1
 x = 50 + i / 3
 y = 99
 CIRCLE (x, y), i / 3, i
 PAINT (x, y), i
NEXT i

' wait until keypress
DO: LOOP WHILE INKEY$ = ""
END


'Run BASIC White Sphere, Black background
'runbasic.com
graphic #win, 300, 300
#win size(1)
 R=100
 R2=R*R
 X0=300/2
 Y0=300/2
for Y = -150 to 150
for X = -150 to 150
 D2 = X*X + Y*Y
 C = 0
 if D2 <= R2 then Z = sqr(R2-D2) : C = int(Z-(X+Y)/2+130)
 #win color(C,C,C)
 #win set(X+X0, Y+Y0)
next X
next Y
render #win

'This is a simple Circle
graphic #g, 300, 300 	'create a graphic object
#g place(100,100) 	'place the drawing pen at 100,100
#g circle(75) 		'make a circle with radius 75
render #g 		'show it

10 LET I=21
20 LET J=2
30 FOR K=-PI TO PI STEP 0.07
40 PLOT 21+I*SIN K,22+21*COS K
50 PLOT 21+21*SIN K,22+(I-1)*COS K
60 NEXT K
70 LET I=I-J
80 LET J=J+1
90 IF I>0 THEN GOTO 30