run length blit 2024

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: run length blit - May 12

Post by dodicat »

The draw command is really a little string parser.
Have a look at draw in the help files.
neil
Posts: 555
Joined: Mar 17, 2022 23:26

Re: run length blit - May 12

Post by neil »

dafhi matybe you could use angros47 starfield for a game. Although you said vertical scrolling game. I like it because it's a nice starfield effect.

Code: Select all

const w=800: const h=600

screenres w, h, 8


Dim pal(0 To 255) As Integer

dim as single x, y, c, sx, sy, sc
c=1.0

for i as integer=1 to 300
	x=w/2: y=h/2
	sx=(rnd()*2.0)-1.0
	sy=(rnd()*2.0)-1.0
	sc=rnd()
	do
		x+=sx: y+=sy: c+=sc
		if c>255.0 then c-=254.0
		pset (x,y), c
	loop until x<0 orelse x>w orelse y<0 orelse y>h

next

dim t as single
dim speed as single=.01

do
	palette using pal

	dim d as integer=&hFF0000-(speed *100)
	for i as integer=1 to 255
		if pal(i) then pal(i)=pal(i)/20*19 and &hFF0000
	next
	t= (t+speed) 
	if t>=255.0 then t-=254.0
	pal (t+.5)=&hFFFFFF

	if multikey(&h49) andalso speed <1 then speed+=.001
	if multikey(&h51) andalso speed >0.001 then speed-=.001
	'screensync
	sleep 1
loop until multikey(1)
neil
Posts: 555
Joined: Mar 17, 2022 23:26

Re: run length blit - May 12

Post by neil »

After seeing the starfield demo I looked for more 3D type demos and found this qbasic one.
Is there any demo's like this one for FreeBasic? You need to skip ahead to 13 minutes to see the demo.
https://www.youtube.com/watch?v=VL0oGct1S4Q
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: run length blit - May 12

Post by dafhi »

i have so much to do before i will have just the graphics part of an engine.

color reduction https://freebasic.net/forum/viewtopic.php?t=25956
procedural + combinatoric ship parts (+ terrain and other stuff)
terminal vel w/ accel consistent across all frame rates (personal 15 year challenge)

dodicat that's a real nice plug-and-play zoom.
paul doe
Moderator
Posts: 1730
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: run length blit - May 12

Post by paul doe »

neil wrote: May 14, 2023 2:11 ...
Is there any demo's like this one for FreeBasic?
...
https://github.com/glasyalabolas/fb-3d-playground

Interactive demo and small framweork for learning some 3D concepts.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: run length blit - May 12

Post by dodicat »

neil wrote: May 14, 2023 2:11 After seeing the starfield demo I looked for more 3D type demos and found this qbasic one.
Is there any demo's like this one for FreeBasic? You need to skip ahead to 13 minutes to see the demo.
https://www.youtube.com/watch?v=VL0oGct1S4Q
Here is a simple starfield similar to your QB thing.
I have used screenset with flip instead of
screenlock
screenunlock
(any would do)
I have sorted the circles by radius.

Code: Select all



Screen 20,32,2,64 
Screenset 1,0
#define irange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
#define ub 100+rnd*155
#define onscreen(x,y) (x>0 and x<1024 and y>0 and y<768)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)

'=========  set up c sort =========
#include "crt/stdlib.bi"
#define Array(x,start,finish) @X((start)),((finish)-(start)+1),Sizeof(X)
#macro SetCSort(Datatype,FnName,direction,dot)
Function FnName Cdecl(n1 As Const Any Ptr,n2 As Const Any Ptr) As Long
      If direction=down Then
            If (*Cptr(Datatype Ptr,n1))dot > (*Cptr(Datatype Ptr,n2))dot Then Return -1
            If (*Cptr(DataType Ptr,n1))dot < (*Cptr(DataType Ptr,n2))dot Then Return 1
      Else
            If (*Cptr(Datatype Ptr,n1))dot < (*Cptr(Datatype Ptr,n2))dot Then Return -1
            If (*Cptr(DataType Ptr,n1))dot > (*Cptr(DataType Ptr,n2))dot Then Return 1
      End If
      Return 0
End Function
#endmacro

Enum
      up
      down
End Enum

Type pt
      As Single x,y,z
      As Ulong col
      r As Long
End Type

setCsort(pt,ptcallback,up,.r)

Sub orb(cx As Long,cy As Long,radius As Long,c As Ulong)
      Dim As Ubyte red=Cptr(Ubyte Ptr,@c)[2]
      Dim As Ubyte green=Cptr(Ubyte Ptr,@c)[1]
      Dim As Ubyte blue=Cptr(Ubyte Ptr,@c)[0]
      For d As Single = radius To 0 Step -radius/32
            var al=iif(d<.6*radius,255,map(radius,0,d,0,255))
            Circle (cx,cy),d,Rgba(red,green,blue,al),,,,F
      Next d
End Sub

Function perspective(p As pt,ep As pt) As pt
      Dim As Single   w=1+(p.z/ep.z)
      Return Type((p.x-ep.x)/w+ep.x, (p.y-ep.y)/w+ep.y,(p.z-ep.z)/w+ep.z,p.col)
End Function 

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


Dim As pt p(1 To 2500),ret(1 To Ubound(p))
For n As Long=1 To Ubound(p)
      p(n)=Type(irange(-300,1100),irange(-300,900),irange(-500,800),Rgb(ub,ub,ub))
Next
Dim  As Single x=512,y=768\2
dim as long fps
Do
      cls
      Draw String(10,10),"Use arrows or space or press ESC to finish"
       Draw String(10,50),"Framerate = " &fps
      For n As Long=1 To Ubound(p)
            p(n).z-=10
            ret(n)=perspective(p(n),Type(x,y,1000))
            ret(n).r=map(-500,800,ret(n).z,3,1)
            If p(n).z<-950 Then p(n).z=irange(100,800)
      Next n
      qsort(array(ret,Lbound(ret),Ubound(ret)),@ptcallback)
      For n As Long=1 To Ubound(ret)
            If onscreen(ret(n).x,ret(n).y) Then orb(ret(n).x,ret(n).y,ret(n).r,ret(n).col)
      Next n
      Flip
      If Multikey(&h48) Then y+=1
      If Multikey(&h50) Then y-=1
      If Multikey(&h4B) Then x-=1
      If Multikey(&h4D) Then x+=1
      If Multikey(&h39) Then x=512:y=768\2
      Sleep regulate(40,fps),1
Loop Until multikey(1)


 
Last edited by dodicat on May 15, 2023 14:22, edited 1 time in total.
hhr
Posts: 206
Joined: Nov 29, 2019 10:41

Re: run length blit - May 12

Post by hhr »

@dodicat
I got error messages:

Code: Select all

R:\FreeBASIC\FreeBASIC-1.10.0-winlibs-gcc-9.3.0>fbc32 test.bas
test.bas(36) error 265: Symbol not a CLASS, ENUM, TYPE or UNION type, before '.' in 'setCsort(pt,ptcallback,up,.r)'
test.bas(36) error 8: Undefined symbol, r in 'setCsort(pt,ptcallback,up,.r)'
test.bas(36) error 3: Expected End-of-Line, found '>' in 'setCsort(pt,ptcallback,up,.r)'
test.bas(36) error 265: Symbol not a CLASS, ENUM, TYPE or UNION type, before '.' in 'setCsort(pt,ptcallback,up,.r)'
test.bas(36) error 3: Expected End-of-Line, found '<' in 'setCsort(pt,ptcallback,up,.r)'
test.bas(36) error 265: Symbol not a CLASS, ENUM, TYPE or UNION type, before '.' in 'setCsort(pt,ptcallback,up,.r)'
test.bas(36) error 3: Expected End-of-Line, found '<' in 'setCsort(pt,ptcallback,up,.r)'
test.bas(36) error 265: Symbol not a CLASS, ENUM, TYPE or UNION type, before '.' in 'setCsort(pt,ptcallback,up,.r)'
test.bas(36) error 3: Expected End-of-Line, found '>' in 'setCsort(pt,ptcallback,up,.r)'

R:\FreeBASIC\FreeBASIC-1.10.0-winlibs-gcc-9.3.0>
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: run length blit - May 12

Post by dodicat »

Hi hhr.
No errors in the official build (1.09), but I see what you mean.
I'll look into it for 1.10.
The bog standard quicksort is OK in the meantime.

Code: Select all

Screen 20,32,2,64 
Screenset 1,0
#define irange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
#define ub 100+rnd*155
#define onscreen(x,y) (x>0 and x<1024 and y>0 and y<768)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)

'=========  set up quick sort =========
#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
    Sub fname(array() As datatype,begin As Long,Finish As long)
    Dim As Long i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
        While array(I)dot b1 X dot:I+=1:Wend
        While array(J)dot b2 X dot:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
    Wend
    If J > begin Then fname(array(),begin,J)
    If I < Finish Then fname(array(),I,Finish)
    End Sub
#endmacro  

Type pt
      As Single x,y,z
      As Ulong col
      r As Long
End Type

SetQsort(pt,ptsort,up,.r)

Sub orb(cx As Long,cy As Long,radius As Long,c As Ulong)
      Dim As Ubyte red=Cptr(Ubyte Ptr,@c)[2]
      Dim As Ubyte green=Cptr(Ubyte Ptr,@c)[1]
      Dim As Ubyte blue=Cptr(Ubyte Ptr,@c)[0]
      For d As Single = radius To 0 Step -radius/32
            var al=iif(d<.6*radius,255,map(radius,0,d,0,255))
            Circle (cx,cy),d,Rgba(red,green,blue,al),,,,F
      Next d
End Sub

Function perspective(p As pt,ep As pt) As pt
      Dim As Single   w=1+(p.z/ep.z)
      Return Type((p.x-ep.x)/w+ep.x, (p.y-ep.y)/w+ep.y,(p.z-ep.z)/w+ep.z,p.col)
End Function 

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


Dim As pt p(1 To 2500),ret(1 To Ubound(p))
For n As Long=1 To Ubound(p)
      p(n)=Type(irange(-300,1100),irange(-300,900),irange(-500,800),Rgb(ub,ub,ub))
Next
Dim  As Single x=512,y=768\2
dim as long fps
Do
      cls
      Draw String(10,10),"Use arrows or space or press ESC to finish"
       Draw String(10,50),"Framerate = " &fps
      For n As Long=1 To Ubound(p)
            p(n).z-=10
            ret(n)=perspective(p(n),Type(x,y,1000))
            ret(n).r=map(-500,800,ret(n).z,3,1)
            If p(n).z<-950 Then p(n).z=irange(100,800)
      Next n
      ptsort(ret(),Lbound(ret),Ubound(ret))
      For n As Long=1 To Ubound(ret)
            If onscreen(ret(n).x,ret(n).y) Then orb(ret(n).x,ret(n).y,ret(n).r,ret(n).col)
      Next n
      Flip
      If Multikey(&h48) Then y+=1
      If Multikey(&h50) Then y-=1
      If Multikey(&h4B) Then x-=1
      If Multikey(&h4D) Then x+=1
      If Multikey(&h39) Then x=512:y=768\2
      Sleep regulate(40,fps),1
Loop Until multikey(1)

 
OK, I have fixed the crt sort in the original starfield.
Extra brackets needed for fb 1.10
neil
Posts: 555
Joined: Mar 17, 2022 23:26

Re: run length blit - May 12

Post by neil »

@dodicat
This is a very nice 3D starfield effect with colorful orbs.
Now I am trying to figure out how you did it. Thanks for your demo.
neil
Posts: 555
Joined: Mar 17, 2022 23:26

Re: run length blit - May 12

Post by neil »

dodicat's 3D colorful orbs would be great for a flight simulator.
Maybe a spaceship flight simulator.
neil
Posts: 555
Joined: Mar 17, 2022 23:26

Re: run length blit - May 12

Post by neil »

@dodicat
The crt sort and the bog standard quick sort both run fine on Linux using FreeBasic version 1.10.
It was also tested on Windows 10, and both versions run fine.
Is the crt sort version faster?
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: run length blit - May 12

Post by dafhi »

the quicksort rabbit hole : )

if i remember correctly, dodicat's beats c

Munair had a fast one, i haven't been able to find it
neil
Posts: 555
Joined: Mar 17, 2022 23:26

Re: run length blit - May 12

Post by neil »

@dafhi
About quicksort. I ran both versions. I don't see any difference in speed visually with dodicat's 3D-orbs. Anyways now we just need to to put in a window in the 3D-orbs.bas and it will look like were in a spaceship. Maybe something like this.
https://www.youtube.com/watch?v=BHrJDTBvcBA
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: run length blit - May 12

Post by dafhi »

3d is easy
projection.x = point.x / point.z + screen_w / 2
neil
Posts: 555
Joined: Mar 17, 2022 23:26

Re: run length blit - May 12

Post by neil »

@dafhi
You wrote "3d is easy" "projection.x = point.x / point.z + screen_w / 2"
How would you make this look more 3D? Like it is really moving.

Code: Select all

function map(a as double,b as double,x as double,c as double,d as double) as double
    return (d-c)*(x-a)/(b-a)+c
end function

Dim As Ulong i, j, r, x, y, Red, Green, Blue
Color 15,0
Cls
ScreenRes 800, 600, 32
Locate 10,40:Print "DEMO HAS STARTED"

for j = 1 to 5
sleep 2000,1
Cls
x = 380: y = 160:r = 30

FOR i  = 1 TO r 
    red=map(1,r,i,255,25)
    green=map(1,r,i,255,25)
    blue=map(1,r,i,255,25)
CIRCLE (x, y),i, RGB(Red, Green, Blue)
CIRCLE (x, y + 1),i, RGB(Red, Green, Blue)
sleep 60,1
next
next
Locate 30,40: Print "DEMO HAS FINISHED"
sleep
Post Reply