EXAMPLE SOURCE CODES


     This is a small collection of mostly game example source codes. These source codes are made available to help PlayBasic programmers kick start their game programming journey. Looking for more source code / tutorials & media, then remember to visit the PlayBasic Resource board on our forums.

Found #151 items

 GetAbsolutePathToFile

By: Kevin Picone Added: January 8th, 2023

Category: All,Files


  GetAbsolutePathToFile


    This function takes a base path and then computes the absolute path from this base from an assumed relative path in the file name





PlayBasic Code:
	BasePath$="D:\MyProjectFolder\Gfx\_examples"
	ink $ff0000
	print BasePath$	
	ink -1

	print ""	
	print  GetAbsolutePathToFile(BasePath$, "Stuff.txt")
	print  GetAbsolutePathToFile(BasePath$, "subfolder/Stuff.txt")
	print  GetAbsolutePathToFile(BasePath$, "../Stuff.txt")
	print  GetAbsolutePathToFile(BasePath$, "../../Stuff.txt")
	print  GetAbsolutePathToFile(BasePath$, "subfolder/../../Stuff.txt")
	
	

	Sync
	waitkey
	

Function GetAbsolutePathToFile(BasePath$, Filename$)

		BasePath$=replace$(BasePath$,"/","\")	
		Filename$=replace$(Filename$,"/","\")	

		Filename$=trim$(Filename$)
		BasePath$=trimright$(BasePath$,"\")+"\"
	
		local Device$=GetDevicename$(Filename$)	 
		if len(Device$)=0
			
			//  if the Filename is relative, we'll try and
			//  build an absolute path from BASE to this Filename
				local Path$=GetFolderName$(Filename$)	 

				 FileName$=BasePath$+Filename$

			// Check for "..\" in path
				if instring(Path$,"..\")
	
					Dim FolderChunks$(50)
					local Count=splittoarray(filename$,"\",FolderChunks$())
					
					local lp,s$
					local Output=0
					
					
					for lp =0 to count-1
						s$=FolderChunks$(lp)
						if s$<>".." 
							if output>=0  then FolderChunks$(Output)=s$
							Output++		
						else
							output--	
						endif	
					next	

					// Put it back together
					Filename$=""
					for lp =0 to output-1
						Filename$+=FolderChunks$(lp)
						if lp<output-1 then Filename$+="\"
					next	
												
				endif 				
	
		endif
	

EndFunction Filename$











   Example output:

CODE:

D:\MyProjectFolder\Gfx\_examples D:\MyProjectFolder\Gfx\_examples\Stuff.txt D:\MyProjectFolder\Gfx\_examples\subfolder\Stuff.txt D:\MyProjectFolder\Gfx\Stuff.txt D:\MyProjectFolder\Stuff.txt D:\MyProjectFolder\Gfx\Stuff.txt









 Lines Intersect

By: Kevin Picone Added: January 7th, 2023

Category: All,LinesIntersect,Math

    This code is a function that determines if two lines intersect and returns the intersection point as the coordinates (x,y). The function takes in the starting and ending x and y coordinates for each line as arguments. The function first calculates the slope and length of each line. It then uses these values to determine if the lines intersect and, if they do, calculates the intersection point. The function returns a boolean value indicating whether the lines intersect, as well as the x and y coordinates of the intersection point. The function is called in a loop that clears the screen, draws the two lines with the mouse coordinates as one of the endpoints, and prints the intersection point (if the lines intersect).

PlayBasic Code:
Do
// Clear the screen
Cls

// Set line1StartX, line1StartY, line1EndX, and line1EndY to variables
line1StartX=100
line1StartY=100
line1EndX = mousex()
line1EndY = mousey()

// Set line2StartX, line2StartY, line2EndX, and line2EndY to variables
line2StartX=20
line2StartY=200
line2EndX=1000
line2EndY=700

// Draw line1 in black
linec line1StartX, line1StartY, line1EndX, line1EndY,-1

// Draw line2 in green
linec line2StartX, line2StartY, line2EndX, line2EndY,$00ff00

// Check if lines intersect
State,x#,y#=Lines_Intersect(line1StartX, line1StartY, line1EndX, line1EndY,_
            line2StartX, line2StartY, line2EndX, line2EndY)

// Print intersect state
print State

// If lines intersect, draw a red circle at intersect point
if State
	Circlec X#,y#,10,true,$ff0000
endif

// Display the screen

sync
loop spacekey()

	end


 
Function Lines_Intersect(line1StartX, line1StartY, line1EndX, line1EndY, line2StartX, line2StartY, line2EndX, line2EndY)

// Initialize variables
intersects = False
intersectX = 0
intersectY = 0
s1_x# = line1EndX - line1StartX
s1_y# = line1EndY - line1StartY
s2_x# = line2EndX - line2StartX
s2_y# = line2EndY - line2StartY

// Calculate s and t
s# = (-s1_y# * (line1StartX - line2StartX) + s1_x# * (line1StartY - line2StartY)) / (-s2_x# * s1_y# + s1_x# * s2_y#)
t# = ( s2_x# * (line1StartY - line2StartY) - s2_y# * (line1StartX - line2StartX)) / (-s2_x# * s1_y# + s1_x# * s2_y#)

// Check if s and t are within valid range
if s# >= 0 and s# <= 1 and t# >= 0 and t# <= 1
	// Set intersects to true and calculate intersectX and intersectY
    intersects = True
    intersectX# = line1StartX + (t# * s1_x#)
    intersectY# = line1StartY + (t# * s1_y#)
EndIf

// Return intersects, intersectX, and intersectY

EndFunction intersects, intersectX#, intersectY#



COMMANDS USED: CLS | MOUSEX | MOUSEY | LINEC | PRINT | CIRCLEC | SYNC | SPACEKEY | AND |




 Merged Sorted Arrays

By: Kevin Picone Added: January 7th, 2023

Category: All,Arrays,Sort

  Merged Sorted Arrays

 This function takes two two sorted Integer (Numeric) and merged them into a new array.  

PlayBasic Code:
	Size=100

	Dim Test1(Size)
	Dim Test2(Size)

	; fill both arrays with some random integers between 0 and 1000
	for lp =0 to Size
			Test1(lp)=rnd(1000)
			Test2(lp)=rnd(1000)
	next

	; Place a couple of value at the end of our arrays to check we're
	; getting all the values in the merged output
	test1(Size) = 5000
	test2(Size) = 9999
	

	;  Sort the Arrays 
	SortArray Test1(),0,Size
	SortArray Test2(),0,Size


	Dim Result(0)


	Result()=MergeSortedArrays(Test1(), Test2())

	Sync
	waitkey
	



Function MergeSortedArrays(a(), b())

  ; dim our arrat C() to hold both merged arrays
    A_Size  =getarrayelements(a())
	 B_Size  =getarrayelements(b())



	 ; output array total size
  	 C_Size = A_Size+B_Size+1
    Dim c(C_Size)

    ; Initialize variables to track the current position in each array
    i = 0
    j = 0
   	for LP=0 to C_Size
    	  ; Check if the value in array A is
    	  ; smaller than the value in array B

	      if a(i) < b(j) 
             ; Add the value from array A to the merged array
            c(lp) = a(i)
            i++ ; Move to the next element in array A

				; Check if we're out of values in array A	
				if i>A_Size
					; If so, we copy the rest of B() to C()
					For CopyLP = j to B_Size
						LP++	
						c(LP)=b(CopyLP)
					next

   			endif
   			
        Else 
        		
        		; Otherwise, the value in array B is smaller
            ; Add the value from array B to the merged array
            c(lp) = b(j)
            j++ ; Move to the next element in array B

				; Check if we're out of values in array B	
				if j>B_Size

					; if so, we can copy the rest of A() to C()
					For CopyLP = i to A_Size
						LP++	
						c(lp)=a(CopyLP)
					next
				endif
				
        Endif

    next lp
    ; Return the merged array
EndFunction c() 




COMMANDS USED: DIM | RND | SORTARRAY | SYNC | WAITKEY | GETARRAYELEMENTS |


   Learn To Code How it Works:    The function called MergeSortedArrays takes two sorted arrays, a and b, as input and returns a new array containing the merged and sorted values from both input arrays.

   The function starts by declaring a new array, c, to hold the merged values of the two input arrays. It then initializes three variables, i, j, and lp, which will be used to track the current position in each of the input arrays and to loop through the elements of the output array.

   The function then enters a FOR loop which will iterate lp from 0 to the size of the output array. Inside the loop, the function compares the current element of array a to the current element of array b. If the element from array a is smaller, it is added to the merged array and the i variable is incremented to move to the next element in array a. If the element from array b is smaller, it is added to the merged array and the j variable is incremented to move to the next element in array b.

  If the end of either array a or b is reached, the rest of the values in the other array are added to the output array in a separate FOR loop. Finally, the function returns the merged array c.





 Gouraud Shaded Torus - Blitz Basic 2D Port

By: Kevin Picone Added: January 7th, 2023

Category: All,3D,Gouraud,Torus,BlitzBASIC

  3D Gouraud Shaded Torus  - 14th March 2022

    This example rendering  spinning gouraud shaded torus in 3D, purely in software.  The code is translation of an old Blitz BASIC program that was converted and tweaked to run in PlayBasic.


   Note:  Download attachment for the FULL code it's too big for a snippet


 



 
PlayBasic Code:
; PROJECT : 3d_v2_Torus_PB_Version
; AUTHOR  : Paul Rene J?rgensen  & Kev Picone
; CREATED : 12/03/2022
; EDITED  : 14/03/2022
; ---------------------------------------------------------------------

;--------------------------------------------------------------------------------
	#include "BlitzWrapper.pba"
;--------------------------------------------------------------------------------


; 3d
;
;       Author : Paul Rene J?rgensen, <>
;  Last update : 20. February, 2001
;
; 9 Muls rotator, Mergesort, Gourad shader,
; Backface-culling, Vector based lightsource


Global numvertex,numpoly
Global width=640
Global height=480

BB_Graphics width,height,32,2
BB_AppTitle("Gourad shading")

BB_SetBuffer BB_BackBuffer()

Dim xpos(height,2)
Dim zpos(height,2)
Dim rpos(height,2)
Dim gpos(height,2)
Dim bpos(height,2)

Type tlightsource
   x,y,z
EndType

Type tvertex
   x,y,z
   xr,yr,zr
   nx,ny,nz
   nxr,nyr,nzr
   x2d,y2d
EndType

Type tpoly
   v0,v1,v2,v3
   order
EndType

Restore MyObject
	numvertex = Readdata()
	numpoly		=ReadData()

Dim zcenter(numpoly)
Dim zworking(numpoly)
Dim ordertable(numpoly)
Dim oworking(numpoly)

Restore coords
Dim vertex(numvertex) as tvertex
For n=0 To numvertex-1
  vertex(n)=New tvertex
  vertex(n).x = Readdata()
  vertex(n).y= Readdata()
  vertex(n).z= Readdata()
Next
Restore pnorms
For n=0 To numvertex-1
  vertex(n).nx = Readdata()
  vertex(n).ny = Readdata()
  vertex(n).nz = Readdata()
Next

Restore polys
Dim poly(numpoly) as tpoly
For n=0 To numpoly-1
  poly(n)=New tpoly
 ; BB_Read dum,dum
  dum = Readdata()
  dum = Readdata()
  poly(n).v0 = Readdata()
  poly(n).v1 = Readdata()
  poly(n).v2 = Readdata()
  poly(n).v3 = Readdata()
Next

Dim lightsource(2) as tlightsource
lightsource(0)=New tlightsource
lightsource(0).x=256
lightsource(0).y=256
lightsource(0).z=-256


x_angle=0
y_angle=0
z_angle=0

;setfps 31.7

global RenderMethod =0 

While Not BB_KeyDown(1)

	if enterKey()
		RenderMethod++
		if RenderMethod>2 then RenderMethod=0
		flushkeys
	endif

	select RenderMethod
			case 0
				Render_Method_Name$ ="fastDot inner loop"
			case 1
				Render_Method_Name$ ="gouraud strip inner loop"
			case 2
				Render_Method_Name$ ="gouraud triangle"
	endselect

  rotate_transform_vertices(x_angle,y_angle,z_angle)
  sort_polys()
  BB_Cls()
  draw_polys()
 ; draw_vertices()
  lfps=(1000/(BB_MilliSecs()-t))
  t=BB_MilliSecs()
  Text 10,10,"Current FPS : "+str$(lfps)
  Text 10,30,"Highest FPS : "+str$(hfps)
  Text 10,40,"Average FPS : "+str$(afps#)
  Text 10,50," Lowest FPS : "+str$(lfps)
  Text 10,60,"     Render : "+Render_Method_Name$
 
  Text 210,10,"  Points : "+str$(numvertex)
  Text 210,20,"Polygons : "+str$(numpoly)
 
  
  If hfps=0 Then hfps=lfps
  If lfps=0 Then lfps=lfps
  If afps#=0 Then afps#=lfps : afpscount=1
  If lfps>hfps Then hfps=lfps
  If lfps<lfps Then lfps=lfps
  afps#=((afps#*afpscount)+lfps)/(afpscount+1)
  afpscount=afpscount+1
  BB_Flip()
  x_angle=x_angle+1
  y_angle=y_angle+2
  z_angle=z_angle+4
  If x_angle>360 Then x_angle=x_angle-360
  If y_angle>360 Then y_angle=y_angle-360
  If z_angle>360 Then z_angle=z_angle-360


	if Spacekey() then end
	quittime=quittime+1
	If quittime> 25000 Then End
EndWhile



Function draw_polys()
  lockbuffer
    ThisRGB = point(0,0)
		
	  For n=0 To numpoly-1
	  index=ordertable(n)	
    v0=poly(index).v0
    v1=poly(index).v1
    v2=poly(index).v2

    x1=vertex(v0).x2d
    y1=vertex(v0).y2d
    nx=vertex(v0).nxr
    ny=vertex(v0).nyr
    nz=vertex(v0).nzr
    c1=((nx*lightsource(0).x)+(ny*lightsource(0).y)+(nz*lightsource(0).z))/256
    If c1<0 Then c1=0
    If c1>255 Then c1=255

    x2=vertex(v1).x2d
    y2=vertex(v1).y2d
    nx=vertex(v1).nxr
    ny=vertex(v1).nyr
    nz=vertex(v1).nzr
    c2=((nx*lightsource(0).x)+(ny*lightsource(0).y)+(nz*lightsource(0).z))/256
   ; If c2<0 Then c2=0
   ; If c2>255 Then c2=255
	c2=cliprange(c2,0,255)
		

    x3=vertex(v2).x2d
    y3=vertex(v2).y2d
    nx=vertex(v2).nxr
    ny=vertex(v2).nyr
    nz=vertex(v2).nzr
    c3=((nx*lightsource(0).x)+(ny*lightsource(0).y)+(nz*lightsource(0).z))/256
    If c3<0 Then c3=0
    If c3>255 Then c3=255
 
    ; Back-face culling
    If (x3-x1)*(y2-y1)-(x2-x1)*(y3-y1)>=0
    	Select RenderMethod
    			case 0
		     		 gpolygon(x1,y1,c1,c1,c1,x2,y2,c2,c2,c2,x3,y3,c3,c3,c3)
    			case 1
		     		 gpolygon1(x1,y1,c1,c1,c1,x2,y2,c2,c2,c2,x3,y3,c3,c3,c3)
    			case 2
		     		 gpolygon2(x1,y1,c1,c1,c1,x2,y2,c2,c2,c2,x3,y3,c3,c3,c3)
	  endselect
     ; Line vertex(v0).x2d,vertex(v0).y2d,vertex(v1).x2d,vertex(v1).y2d
;      Line vertex(v1)\x2d,vertex(v1)\y2d,vertex(v2)\x2d,vertex(v2)\y2d
;      Line vertex(v2)\x2d,vertex(v2)\y2d,vertex(v0)\x2d,vertex(v0)\y2d
    EndIf
  Next
  unlockbuffer
EndFunction 0


Function draw_vertices()
  BB_LockBuffer 0
  lRGB=(255 << 16)+(255 << 8)+255
  For n=0 To numvertex-1
    BB_WritePixel vertex(n).x2d,vertex(n).y2d,lRGB,0
  Next
  BB_UnlockBuffer 0
EndFunction 0



Function sort_polys()
  For n=0 To numpoly-1
    v0=poly(n).v0
    v1=poly(n).v1
    v2=poly(n).v2
    z1=vertex(v0).zr
    z2=vertex(v1).zr
    z3=vertex(v2).zr
    z=z1+z2+z3
    zcenter(n)=z
    ordertable(n)=n    
  Next
  mergesort(0,numpoly-1)
EndFunction 0

Function mergesort(lo,hi)
  ; Base case
  If lo=hi Then ExitFUNCTION 0

  ; Recurse
  length=hi-lo+1
  pivot=(lo+hi)/2
  mergesort(lo,pivot)
  mergesort(pivot+1,hi)

  ; Merge
  For i=0 To length-1
    zworking(i)=zcenter(lo+i)
    oworking(i)=ordertable(lo+i)
  Next
  m1=0
  m2=pivot-lo+1
  For i=0 To length-1
    If m2<=(hi-lo)
      If m1<=(pivot-lo)
        If zworking(m1)<zworking(m2)
          ordertable(i+lo)=oworking(m2)
          zcenter(i+lo)=zworking(m2)
          m2=m2+1
        Else
          ordertable(i+lo)=oworking(m1)
          zcenter(i+lo)=zworking(m1)
          m1=m1+1
        EndIf
      Else
        ordertable(i+lo)=oworking(m2)
        zcenter(i+lo)=zworking(m2)
        m2=m2+1
      EndIf
    Else
      ordertable(i+lo)=oworking(m1)
      zcenter(i+lo)=zworking(m1)
      m1=m1+1
    EndIf
  Next
EndFunction 0  // Assumed Integer return


Function rotate_transform_vertices(x_angle,y_angle,z_angle)
  ; 9 muls rotator
  c1#=Cos(x_angle)
  c2#=Cos(y_angle)
  c3#=Cos(z_angle)
  s1#=Sin(x_angle)
  s2#=Sin(y_angle)
  s3#=Sin(z_angle)
  xx#=c2#*c1#
  xy#=c2#*s1#
  xz#=s2#
  yx#=c3#*s1#+s3#*s2#*c1#
  yy#=-c3#*c1#+s3#*s2#*s1#
  yz#=-s3#*c2#
  zx#=s3#*s1#-c3#*s2#*c1#
  zy#=-s3#*c1#-c3#*s2#*s1#
  zz#=c3#*c2#
width2=width/2
height2=height/2
widthbyheight=(width/height)*256
  For n=0 To numvertex-1
    ; Vertices
    vertex(n).xr=xx#*vertex(n).x+xy#*vertex(n).y+xz#*vertex(n).z
    vertex(n).yr=yx#*vertex(n).x+yy#*vertex(n).y+yz#*vertex(n).z
    vertex(n).zr=zx#*vertex(n).x+zy#*vertex(n).y+zz#*vertex(n).z
    ; Vertice Normals
    vertex(n).nxr=xx#*vertex(n).nx+xy#*vertex(n).ny+xz#*vertex(n).nz
    vertex(n).nyr=yx#*vertex(n).nx+yy#*vertex(n).ny+yz#*vertex(n).nz
    vertex(n).nzr=zx#*vertex(n).nx+zy#*vertex(n).ny+zz#*vertex(n).nz
    ; 3d -> 2d transformation
    vertex(n).x2d=(widthbyheight*vertex(n).xr)/(vertex(n).zr+1024)+width2
    vertex(n).y2d=(256*vertex(n).yr)/(vertex(n).zr+1024)+height2
  Next
EndFunction 0


Function gpolygon(x1,y1,r1,g1,b1,x2,y2,r2,g2,b2,x3,y3,r3,g3,b3)
	
  For n=0 To height : xpos(n,0)=0 : xpos(n,1)=0 : Next
  drawedge(x1,y1,r1,g1,b1,x2,y2,r2,g2,b2)
  drawedge(x2,y2,r2,g2,b2,x3,y3,r3,g3,b3)
  drawedge(x3,y3,r3,g3,b3,x1,y1,r1,g1,b1)
  miny=y1
  If(miny>y2) Then miny=y2
  If(miny>y3) Then miny=y3
  maxy=y1
  If(maxy<y2) Then maxy=y2
  If(maxy<y3) Then maxy=y3
  minx=x1
  If(minx>x2) Then minx=x2
  If(minx>x3) Then minx=x3
  maxx=x1
  If(maxx<x2) Then maxx=x2
  If(maxx<x3) Then maxx=x3
  For y=miny To maxy
    horizontalline(xpos(y,0),xpos(y,1),y)
  Next
EndFunction 0





Function gpolygon1(x1,y1,r1,g1,b1,x2,y2,r2,g2,b2,x3,y3,r3,g3,b3)
  For n=0 To height : xpos(n,0)=0 : xpos(n,1)=0 : Next
  drawedge(x1,y1,r1,g1,b1,x2,y2,r2,g2,b2)
  drawedge(x2,y2,r2,g2,b2,x3,y3,r3,g3,b3)
  drawedge(x3,y3,r3,g3,b3,x1,y1,r1,g1,b1)
  miny=y1
  If(miny>y2) Then miny=y2
  If(miny>y3) Then miny=y3
  maxy=y1
  If(maxy<y2) Then maxy=y2
  If(maxy<y3) Then maxy=y3
  minx=x1
  If(minx>x2) Then minx=x2
  If(minx>x3) Then minx=x3
  maxx=x1
  If(maxx<x2) Then maxx=x2
  If(maxx<x3) Then maxx=x3
  For y=miny To maxy
    x1=xpos(y,0)
    x2=xpos(y,1)
    r1=rpos(y,0)
    r2=rpos(y,1)
    g1=gpos(y,0)
    g2=gpos(y,1)
    b1=bpos(y,0)
    b2=bpos(y,1)
    
    gouraudstriph x1,rgb(r1,g1,b1) , x2, rgb(r2,b2,g2), y
    
  Next
EndFunction 



Function gpolygon2(x1,y1,r1,g1,b1,x2,y2,r2,g2,b2,x3,y3,r3,g3,b3)
	rgb1=rgb(r1,g1,b1)	
	rgb2=rgb(r2,g2,b2)	
	rgb3=rgb(r3,g3,b3)	
	gouraudtri x1,y1,rgb1,x2,y2,rgb2,x3,y3,rgb3
EndFunction 


Function horizontalline(x1,x2,y)
  If(x1<>x2) ;Then 
    r1=rpos(y,0)
    r2=rpos(y,1)
    g1=gpos(y,0)
    g2=gpos(y,1)
    b1=bpos(y,0)
    b2=bpos(y,1)
    If(x1>x2) ;Then
      temp=x1
      x1=x2
      x2=temp
      temp=r1
      r1=r2
      r2=temp
      temp=g1
      g1=g2
      g2=temp
      temp=b1
      b1=b2
      b2=temp
    EndIf
    rslope=((r2-r1) << 8)/(x2-x1)
    gslope=((g2-g1) << 8)/(x2-x1)
    bslope=((b2-b1) << 8)/(x2-x1)
    r=r1 << 8
    g=g1 << 8
    b=b1 << 8
    
    For x=x1 To x2
      rt=r >> 8
      gt=g >> 8
      bt=b >> 8
 ;     lRGB=(rt << 16)+(gt << 8)+bt
      ;BB_WritePixel x,y,lRGB,BB_BackBuffer()
;      Dotc x,y,lRGB
      fastdot x,y,RGB(rt,gt,bt)
      r=r+rslope
      g=g+gslope
      b=b+bslope
    Next
    
  EndIf
EndFunction 0


Function drawedge(x1,y1,r1,g1,b1,x2,y2,r2,g2,b2)
  side=0
  If(y1<>y2) ;Then
    If(y1>=y2) ;Then
      side=1
      temp=x1
      x1=x2
      x2=temp
      temp=y1
      y1=y2
      y2=temp
      temp=r1
      r1=r2
      r2=temp
      temp=g1
      g1=g2
      g2=temp
      temp=b1
      b1=b2
      b2=temp
    EndIf
    
    Scaler = (1 << 8)
    xslope=((x2-x1) << 8)/(y2-y1)
    rslope=((r2-r1) << 8)/(y2-y1)
    gslope=((g2-g1) << 8)/(y2-y1)
    bslope=((b2-b1) << 8)/(y2-y1)
    x=(x1 << 8)+xslope
    r=(r1 << 8)+rslope
    g=(g1 << 8)+gslope
    b=(b1 << 8)+bslope
    For y=y1+1 To y2
      xpos(y,side)=x >> 8
      rpos(y,side)=r >> 8
      gpos(y,side)=g >> 8
      bpos(y,side)=b >> 8
      x=x+xslope
      r=r+rslope
      g=g+gslope
      b=b+bslope
    Next
  EndIf
EndFunction 0


   //  Object Data removed..  Download full code bellow




  Related Links:

       -  Convert BlitzBASIC Source To PlayBasic
       -  3D Development Forum


  Download:

       Code attached bellow


Download: Login to Download




 Windows API GetWindowRect GetClientRect

By: Kevin Picone Added: October 3rd, 2022

Category: All,Windows,WinAPI,Screen

  GetWindowRect and GetClientRect

GetWindowRect is a function in the Windows API that retrieves the dimensions of the bounding rectangle of a window. It takes a handle to the window as an input parameter and returns the dimensions of the window in a RECT structure, which contains the left, top, right, and bottom coordinates of the rectangle.

GetClientRect is a similar function that retrieves the dimensions of the client area of a window. The client area is the part of the window where the application can draw and is typically smaller than the full window because it excludes the title bar and other non-client elements. Like GetWindowRect, GetClientRect takes a handle to the window as an input parameter and returns the dimensions of the client area in a RECT structure.

Both functions are useful for getting the dimensions of a window or client area, which can be used to position controls within the window or to resize the window to fit its contents. They can be called from any application that has a handle to the window, whether it is the application that created the window or another application.

PlayBasic Code:
  //  Scale 
   OpenScreen 1600,960,32,1  ;  open screen in 'window' mode

    ScaleWindowToDeskTop()

	loadfont "ariel",1, 45


	do 
		cls

			ShowClientArea()
	  	 
	  	 
		   print "Mouse POsition:"
		  	print MouseX()
		  	print MouseY()
  
	   Sync
   loop spacekey()=true
   




	type tWindow_RECT
				X1,Y1
				X2,Y2
	endtype

linkdll "user32.dll"
   SetWindowPos(hwnd,hWndInsertAfter,x,y,cx,cy,wFlags) alias "SetWindowPos" As integer
   GetWindowRect(hwnd,RectPointer) alias "GetWindowRect" As integer
   GetClientRect(hwnd,RectPointer) alias "GetClientRect" As integer

Endlinkdll



Function ScaleWindowToDeskTop()

//  Get the Desk top width/height
   dtw=GetDesktopWidth()
   dth=GetDesktopHeight()*0.96

// Get the PB screens size
;   w=GetScreenWidth()
 ;  h=GetScreenHeight()

   // Get the PB screens window Handle
   hwnd=GetScreenHandle()

   ; Stretch the window to the size users display size
   SetWindowPos(hwnd,hWndInsertAfter,0,0,dtw,dth,wFlags)

   ; Resize PB's GFX viewport to screens (the window) new client area
   StretchGFXscreen

Endfunction



Function ShowClientArea()

		Local Xpos	=GetScreenXpos()
		Local Ypos	=GetScreenYpos()
		Local Width	=GetScreenWidth()
		Local Height=GetScreenHeight()

		local Handle=GetSCreenHandle()

		dim Rect as TWindow_REct pointer
		Rect = new tWindow_RECT
		
		
		print "SCREEN SIZE:"
		print Width
		print Height
		print ""		
		
		
		
		local Status= GetWindowREct(Handle, int(RECT))
		
		if Status
			
			print "Window RECT"
			print Rect.X1
			print Rect.Y1
			print Rect.X2
			print Rect.Y2
			print ""		
	
		endif
	

		local Status= GetClientREct(Handle, int(RECT))
		
		if Status
			print "Client RECT - area inside of window"
			print Rect.X1
			print Rect.Y1
			print Rect.X2
			print Rect.Y2
			print ""
		endif
		free Rect		

EndFunction  X,Y






 Simple Text Menu

By: Kevin Picone Added: June 21st, 2022

Category: All,GUI,Menu

 Simple Text Menu

 While tinkering last night, I wrote a simple menu library that lets the programmer define a list of text options that can have a key and mousing bindings as well.   The library is more a starting point than a end product, but it shows a way how we can wrap a system into library that help us separate that functionality from the main program.   The user can tag a function (by name) that is called when any option is clicked or the key binding is pressed.  


Example:

 So our processing loop looks like this..

PlayBasic Code:
	loadfont "verdana",1 , 48


		cr$=chr$(10)+chr$(13)

	
		Options$ =" L) Load File        [BindKey=38][OnClick=LOAD_FUNCTION]"+cr$
		Options$+=" S) Save File        [BindKey=31][OnClick=SAVE_FUNCTION]"+cr$
		Options$+=" D) Delete File        [BindKey=32][OnClick=DELETE_FUNCTION]"+cr$


	//  
	GUI_CREATE_SIMPLE_MENU(Options$)


	Do	
		cls $304050
		
		 GUI_UPDATE_SIMPLE_MENU_INPUTSTATE()
		 GUI_DRAW_SIMPLE_MENU()
	
	
		action$=GUI_Get_SIMPLE_MENU_CLICKS()
	
		if Len(Action$)
				Index=FunctionIndex(Action$)
				if Index
						CallFunction Action$
				endif
		endif	
		 
		sync
	loop



Function LOad_Function()
	cls 255
			print "LOAD FUNCTION"
EndFunction

Function SAVE_Function()
	cls $00ff00
			Print "SAVE FUNCTION"
EndFunction

Function DELETE_Function()
	cls $ff0000
			Print "DELETE FUNCTION"
EndFunction
	




COMMANDS USED: LOADFONT | CHR$ | CLS | LEN | SYNC | PRINT |




COMPLETE EXAMPLE:

PlayBasic Code:
	loadfont "verdana",1 , 48


		cr$=chr$(10)+chr$(13)

	
		Options$ =" L) Load File        [BindKey=38][OnClick=LOAD_FUNCTION]"+cr$
		Options$+=" S) Save File        [BindKey=31][OnClick=SAVE_FUNCTION]"+cr$
		Options$+=" D) Delete File        [BindKey=32][OnClick=DELETE_FUNCTION]"+cr$


	//  
	GUI_CREATE_SIMPLE_MENU(Options$)


	Do	
		cls $304050
		
		 GUI_UPDATE_SIMPLE_MENU_INPUTSTATE()
		 GUI_DRAW_SIMPLE_MENU()
	
	
		action$=GUI_Get_SIMPLE_MENU_CLICKS()
	
		if Len(Action$)
				Index=FunctionIndex(Action$)
				if Index
						CallFunction Action$
				endif
		endif	
		 
		sync
	loop



Function LOad_Function()
	cls 255
			print "LOAD FUNCTION"
EndFunction

Function SAVE_Function()
	cls $00ff00
			Print "SAVE FUNCTION"
EndFunction

Function DELETE_Function()
	cls $ff0000
			Print "DELETE FUNCTION"
EndFunction
	

//------------------------------------------------------------------
//------------------------------------------------------------------
//------------------------------------------------------------------
//------------------------------------------------------------------
//------------------------------------------------------------------


		Type tSimpleTextMenuInputState
					Status
					MX
					MY
					MB
					ScanCode
		EndType



		Type tSimpleTextMenu
				Caption$

				KeyBindingScanCode				
				FunctionToCall$


				x1,y1,x2,y2		; render position of this on screen
				MouseOver
		EndType

		Dim SimpleTextMenu(256) as tSimpleTextmenu

		Dim SimpleTextmenuInputState as tSimpleTextMenuInputState


function GUI_CREATE_SIMPLE_MENU(MenuOptions$)
	
		// Redim the Global Memu 
		Dim SimpleTextMenu(256) as tSimpleTextmenu

		//
		GUI_INIT_SIMPLE_MENU_INPUTSTATE()		


		dim Rows$(1024)
	
		Options$=Replace$(MenuOptions$,chr$(10),"")
		
		LinesOfText = SplitToArray(options$,chr$(13),rows$(),0,0)
		
		
		MenuIndex =1
		
		for lp=0 to LinesOftext-1
			
					s$=Rows$(lp)
					
					// Check for empty line
					if len(trim$(S$))>0
							Param_KeyBind$		=""
							Param_Onclick$		=""

							Current_Pos =1
							do

								// Look for square brackets							
								Left_pos=instring(s$,"[",Current_pos)
								if Left_Pos
										Right_pos=instring(s$,"]",Current_pos)
										If Right_Pos>Left_Pos
											
											Opcode$=Mid$(s$,Left_pos+1,(Right_Pos-Left_Pos)-1)
											
											
											Current_Pos=Left_pos
											S1$=     Left$(s$,Left_pos-1)
											S2$=  CutLeft$(s$,Right_pos)
											s$=s1$+s2$

											// get Opcode and Value 
											Value$		=""
											Equals_pos  = instring(opcode$,"=")
											if Equals_pos
												Value$	= CutLeft$(Opcode$,Equals_pos)
												Opcode$	=    Left$(Opcode$,Equals_pos-1)
											endif
										
											Select upper$(trim$(opcode$))
														
													//  process embedded opcodes for this menu option	
													case "ONCLICK"
															Param_Onclick$ = value$
												
													case "KEYBIND", "BINDKEY", "KEY"
															Param_KEYBIND$ = value$
															
											EndSelect			
											
											//  reset the next search 
											Current_pos=Left_pos								
										else
											Current_Pos=Left_pos+1	
										endif		
								else
										exitdo																		
								endif
							loop 
							
							// -----------------------------------------------
							if Len(s$)
							// -----------------------------------------------

									SimpleTextMenu(MenuIndex)=New tSimpleTextMenu
									
									SimpleTextMenu(MenuIndex).Caption 				=s$
									SimpleTextMenu(MenuIndex).KeyBindingScanCode  =val(Param_KeyBind$)
									SimpleTextMenu(MenuIndex).FunctionToCall		 =Param_OnClick$
									MenuIndex ++
							endif

					endif			
					
		next		
	
EndFunction



	
function GUI_DRAW_SIMPLE_MENU()
	
		GUI_INIT_SIMPLE_MENU_INPUTSTATE()
	
	
		//  Message includes the ONCLICK=	
		
		MouseStatus = 		SimpleTextmenuInputState.Status
		Mx				= 		SimpleTextmenuInputState.MX
		My 			= 		SimpleTextmenuInputState.MY
		Mb 			= 		SimpleTextmenuInputState.MB

		CursorX		=GetCursorX()
		CursorY		=GetCursorY()	
	
		TH =GettextHeight("|")
		for lp=0 to getArrayElements(SimpleTextMenu())
			if SimpleTextMenu(lp)
			
					T$=SimpleTextMenu(lp).Caption$
					
					CursorX2 = CursorX1+GettextWidth(t$)
					CursorY2 = CursorY1+TH
			
					SimpleTextMenu(lp).x1=CursorX1	
					SimpleTextMenu(lp).X2=CursorX2	
					SimpleTextMenu(lp).Y1=CursorY1	
					SimpleTextMenu(lp).Y2=CursorY2
					
					
					MouseOverState = 0
					if MouseStatus
						if range(My,CursorY1,CursorY2-1)
							inkmode 1+32
							c=GetInk()
							BoxC 0,CursorY1,getSurfaceWidth(),CursorY2,true,RgbFade(c,50)
							inkmode 1
							
							MouseOverState = 1
							
						endif					
					endif

					SimpleTextMenu(lp).MouseOver		=MouseOverState

					// Check if mouse over

					text CursorX1,CursorY1, t$

					CursorY1=CursorY2
			
			endif
		next		
	
EndFunction



Function GUI_Get_SIMPLE_MENU_CLICKS()
	
	
		GUI_INIT_SIMPLE_MENU_INPUTSTATE()
	
	
		MouseStatus = 		SimpleTextmenuInputState.Status
		Mx				= 		SimpleTextmenuInputState.MX
		My 			= 		SimpleTextmenuInputState.MY
		Mb 			= 		SimpleTextmenuInputState.MB
	
		if MouseStatus
			if MB
				for lp=0 to getArrayElements(SimpleTextMenu())
					if SimpleTextMenu(lp)
						if SimpleTextMenu(lp).MouseOver	
							if Mb & 1
								Action$ = SimpleTextMenu(lp).FunctionToCall
							endif
						endif
					endif
				next	
			endif
		endif

		SC = SimpleTextmenuInputState.ScanCode
		if SC	
			for lp=0 to getArrayElements(SimpleTextMenu())
				if SimpleTextMenu(lp)
					if SimpleTextMenu(lp).KeyBindingScanCode=SC
							Action$ = SimpleTextMenu(lp).FunctionToCall
					endif
				endif
			next	
		endif


EndFunction Action$



Function GUI_UPDATE_SIMPLE_MENU_INPUTSTATE()
	
		GUI_INIT_SIMPLE_MENU_INPUTSTATE()

		SimpleTextmenuInputState.Status = true
		SimpleTextmenuInputState.Mx =MouseX()
		SimpleTextmenuInputState.MY =MouseY()
		SimpleTextmenuInputState.MB =MouseButton()


		SimpleTextmenuInputState.ScanCode =ScanCode()
		
	
EndFunction


Function GUI_INIT_SIMPLE_MENU_INPUTSTATE()
	
	
		 if GetArrayStatus(SimpleTextmenuInputState())=false
				Dim SimpleTextmenuInputState as tSimpleTextMenuInputState
		 endif 

	
EndFunction








 2D Vector Library

By: Kevin Picone Added: May 28th, 2022

Category: All

 Vector Library

    This library provides a set of functions for working with 2D vectors. A 2D vector is a geometric object that has both magnitude (length) and direction and can be represented by an ordered pair of real numbers (x, y).

   The functions in this library allow you to create, manipulate, and perform calculations with 2D vectors. Some of the things you can do with these functions include:

  - Set the x and y components of a 2D vector using SetVector2D
  - Convert polar coordinates (angle and radius) to Cartesian coordinates (x and y) using SetPolar2D
  - Copy the values of one 2D vector to another using CopyVector2D
  - Add or subtract two 2D vectors using AddVectors2D or SubVectors2D
  - Multiply or divide two 2D vectors component-wise using MultVectors2D or DivVectors2D
  - Multiply or divide a 2D vector by a scalar value using MultVector2D or DivVector2D
  - Linearly interpolate between two 2D vectors using LerpVector2D
  - Normalize a 2D vector (i.e., set its magnitude to 1) using GetVectorNormal2D
  - Calculate the length or squared length of a 2D vector using GetVectorLength2D or GetVectorSquaredLength2D
  - Check if two 2D vectors are equal using AreVectorsEqual2D
  - Calculate the dot product or cross product of two 2D vectors using DotProduct2D or CrossProduct2D



PlayBasic Code:
; PROJECT : Vector Library
; AUTHOR  : Kevin Picone - PlayBasic Tutor - https://PlayBasic.com
; CREATED : 12/05/2022
; EDITED  : 28/05/2022
; ---------------------------------------------------------------------



		//  Use a typed array to hold all the vectors we'll be using
		Dim vectors(100) as vector2d
		for lp =0 to getArrayElements(vectors())
			vectors(lp)= new vector2D
		next
		
	
		//  declare some pointers of type vector for use in the examples		
		Dim N as vector2d pointer
		Dim V1 as vector2d pointer
		Dim V2 as vector2d pointer
		Dim OldPoint as vector2D pointer

		//  Get pointers to some pre--alloated vectors in our cache array		
		n = Vectors(0).vector2d		
		V1 = Vectors(1).vector2d		
		V2 = Vectors(2).vector2d		


		Dim CurrentPoint as vector2D pointer
		CurrentPOint = Vectors(3).vector2d		
		
		Dim OldPoint as vector2D pointer
		OldPOint = Vectors(4).vector2d		

		Dim Lerp1 as vector2D pointer
		Lerp1 = Vectors(10).vector2d		
		
		Dim Lerp2 as vector2D pointer
		Lerp2 = Vectors(11).vector2d		
		
		
		SetVector2d lerp1, 500,100
		SetPolar2d lerp2, Rnd(36),rndrange(10,100)
		Addvectors2d Lerp2, Lerp2, Lerp1
		
		
		
		// Set up this vector
		Setvector2d OldPOint,Mousex(),MouseY()	
		Flushmouse
		
		// -----------------------------------------------------------
		// -----------------------------------------------------------
		// -----------------------------------------------------------
		Do
		// -----------------------------------------------------------
		// -----------------------------------------------------------
		// -----------------------------------------------------------
				
				CLS
				
								
				// Set up this vecor
				Setvector2d CurrentPoint,Mousex(),MouseY()	
				
				
				circlec OldPoint.X,OldPoint.Y, 50,true, $00ff00 
				
				circle CurrentPoint.X,CurrentPOint.Y, 50,true 
			
			
				// Subtract target from current  N = Old - Current
				Subvectors2d(N , oldPoint,CurrentPoint)

				ypos= 50

				text 10,Ypos, "Delta:"+StrVector2d$(N)

				//  Get the length of this delta vector
				Dist#=GetVectorLenght2D(N)
				
				// normalize N = and store it back in N  
				GetVectorNormal2D(N , N) 

				text 10,Ypos+30, "Normalized:"+StrVector2d$(N)

			
				//  Scale Normal by Dist# 
				Multvector2d(N , N, Dist#)

				text 10,Ypos+60, "Scaled Normalized:"+StrVector2d$(N)

				//  Add origin (current point) back on. 
				Addvectors2d(N , N, CurrentPoint)
				
				text 10,Ypos+90, "Result:"+StrVector2d$(N)

				
				//  Scale it  so we can draw line between them
				line CurrentPOint.x,CurrentPOint.y,n.x,n.y
			
				if Mousebutton()=1
						CopyVector2d OldPoint,CurrentPOint
				endif	
			
			
				//  test lerp
				Linec Lerp1.x,Lerp1.y,Lerp2.x,Lerp2.y, $ff00ff
				
				//  
				LerpFrame		=mod(LerpFrame+1,100)					
				LerpScale#		=LerpFrame/100.0 	
			
				LerpVector2d N,Lerp1,Lerp2,LerpScale#
				
				Circlec n.x , n.y, 5, true ,$ff00ff
	
			
				//  Curve Lerp vector to the one between
				LerpVector2d V1,Lerp1,Lerp2,LerpScale#
				LerpVector2d V2,CurrentPoint,OldPoint,LerpScale#
				LerpVector2d V1,V2,V1,LerpScale#
				Circlec v1.x , v1.y, 5, true ,$ff00ff
			
				LerpVector2d V1,Lerp1,Oldpoint,LerpScale#
				LerpVector2d V2,lerp2,CurrentPoint,LerpScale#
				LerpVector2d V1,V2,V1,LerpScale#
				Circlec v1.x , v1.y, 5, true ,$ff00ff
			
				Sync
	loop  Spacekey()
	
	




   Download Vector Source Code

      -- File Attached bellow

Download: Login to Download




 Hal Teach me to code - Morphing Shapes

By: Kevin Picone Added: May 14th, 2022

Category: All,learn To Code,Shapes

     This tiny source code snippet uses PlayBasic's shapes to draw batches of line fragments. The fragments are all connected in a circle were each vertex is waving and rotating. On their own the effect is really simple; but when you overlay (rotate and scale) a bunch of them on top of each other it creates a sort of button effect similar to the robotic voice in the classic science function movie 2001 A Space Odyssey. Excuse my poor impressions of Hal in this video.. It's just for laughs


Video:


Download: Login to Download




Viewing Page [1] of [19]



Want More Source Codes?:



Release Type: The source code & tutorials found on this site are released as license ware for PlayBasic Users. No Person or Company may redistribute any file (tutorial / source code or media files) from this site, without explicit written permission.

 

 
     
 
       

(c) Copyright 2002 / 2024 Kevin Picone , UnderwareDesign.com  - Privacy Policy   Site: V0.99a [Alpha]