Pipes screensaver for console

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
IchMagBier
Posts: 52
Joined: Jan 13, 2018 8:47
Location: Germany
Contact:

Pipes screensaver for console

Post by IchMagBier »

Image
Some sort of "screensaver" for your console/terminal. Based on Yu-Jie Lin's "pipes.sh", but cooler, since it's written in FreeBasic. Maybe someone rembembers the old Windows 98 OpenGL-screensaver with those pipes?

Code: Select all

const num_pipes=3
dim shared as integer xscale, yscale
xscale=loword(width)
yscale=hiword(width)

dim shared as ushort feld(xscale,yscale),feld_clr(xscale,yscale)

type t_pipe
	as ubyte clr
	as byte direction,olddirection,x,y,timers
	declare sub update()
	declare constructor
end type

randomize

constructor t_pipe
	x=rnd()*xscale
	y=rnd()*yscale
	clr=rnd()*14+1
end constructor

sub t_pipe.update()
	timers+=1
	if timers>3 then
		direction=rnd()*3
		if direction=0 and olddirection=2 then exit sub
		if direction=2 and olddirection=0 then exit sub
		if direction=1 and olddirection=3 then exit sub
		if direction=3 and olddirection=1 then exit sub
		timers=0
	else
		olddirection=direction
	end if
	if x>xscale-1 then x=0
	if y>yscale-1 then y=0
	if x<0 then x=xscale-1
	if y<0 then y=yscale-1
	feld_clr(x,y)=clr
	if direction=0 then		'Runter
		select case as const olddirection
			case 0
				if feld(x,y)=&h2501 then 
					feld(x,y)=&h254B
				else
					feld(x,y)=&h2503
				end if
			case 1:feld(x,y)=&h2513
			case 3:feld(x,y)=&h250F
		end select
		y+=1
	elseif direction=2 then		'Hoch
		select case as const olddirection
			case 2
				if feld(x,y)=&h2501 then 
					feld(x,y)=&h254B
				else
					feld(x,y)=&h2503
				end if
			case 1:feld(x,y)=&h251B
			case 3:feld(x,y)=&h2517
		end select
		y-=1
	elseif direction=1 then		'Rechts
		select case as const olddirection
			case 0:feld(x,y)=&h2517
			case 2:feld(x,y)=&h250F
			case 1
				if feld(x,y)=&h2503 then 
					feld(x,y)=&h254B
				else
					feld(x,y)=&h2501
				end if
		end select
		x+=1
	elseif direction=3 then		'Links
		select case as const olddirection
			case 0:feld(x,y)=&h251B
			case 2:feld(x,y)=&h2513
			case 3
				if feld(x,y)=&h2503 then 
					feld(x,y)=&h254B
				else
					feld(x,y)=&h2501
				end if
		end select
		x-=1
	end if
end sub

sub render()
	locate 0,0
	for y as integer=0 to yscale-1
		for x as integer=0 to xscale-1
			if feld(x,y)=0 then print " ";
			color feld_clr(x,y)
			print wchr(feld(x,y));
		next
		print
	next
end sub

dim as t_pipe pipes(num_pipes-1)

do
	for i as integer=0 to num_pipes-1
		pipes(i).update()
		sleep 5,1
	next
	render()
loop until inkey=chr(27)
sero
Posts: 59
Joined: Mar 06, 2018 13:26
Location: USA

Re: Pipes screensaver for console

Post by sero »

Your code was not doing as intended on my Windows 10 machine. It was scrolling the console vertically. I made a few alterations so it does what it's supposed on my end. I'm thinking my problem has to do with a different default font size than what you programmed for. I also should mention that my CPU is cranking up to about 20-30% just to run this code. I'm not familiar with freebasic console mode but I'm thinking maybe it is more CPU intensive than I presumed.

Code: Select all

const num_pipes=7
dim shared as long xscale, yscale
xscale=loword(width)
yscale=hiword(width)

dim shared as ushort feld(xscale,yscale),feld_clr(xscale,yscale)

type t_pipe
   as ubyte clr
   as byte direction,olddirection,x,y,timers
   declare sub update()
   declare constructor
end type

randomize

constructor t_pipe
   x=rnd()*xscale
   y=rnd()*yscale
   clr=rnd()*14+1
end constructor

sub t_pipe.update()
   timers+=1
   if timers>3 then
      direction=rnd()*3
      if direction=0 and olddirection=2 then exit sub
      if direction=2 and olddirection=0 then exit sub
      if direction=1 and olddirection=3 then exit sub
      if direction=3 and olddirection=1 then exit sub
      timers=0
   else
      olddirection=direction
   end if
   if x>xscale-1 then x=0
   if y>yscale-1 then y=0
   if x<0 then x=xscale-1
   if y<0 then y=yscale-1
   feld_clr(x,y)=clr
   if direction=0 then      'Runter
      select case as const olddirection
         case 0
            if feld(x,y)=&h2501 then
               feld(x,y)=&h254B
            else
               feld(x,y)=&h2503
            end if
         case 1:feld(x,y)=&h2513
         case 3:feld(x,y)=&h250F
      end select
      y+=1
   elseif direction=2 then      'Hoch
      select case as const olddirection
         case 2
            if feld(x,y)=&h2501 then
               feld(x,y)=&h254B
            else
               feld(x,y)=&h2503
            end if
         case 1:feld(x,y)=&h251B
         case 3:feld(x,y)=&h2517
      end select
      y-=1
   elseif direction=1 then      'Rechts
      select case as const olddirection
         case 0:feld(x,y)=&h2517
         case 2:feld(x,y)=&h250F
         case 1
            if feld(x,y)=&h2503 then
               feld(x,y)=&h254B
            else
               feld(x,y)=&h2501
            end if
      end select
      x+=1
   elseif direction=3 then      'Links
      select case as const olddirection
         case 0:feld(x,y)=&h251B
         case 2:feld(x,y)=&h2513
         case 3
            if feld(x,y)=&h2503 then
               feld(x,y)=&h254B
            else
               feld(x,y)=&h2501
            end if
      end select
      x-=1
   end if
end sub

sub render()
  for y as long=0 to yscale-1
    for x as long=0 to xscale-1
      locate y, x
      color feld_clr(x,y)
      print wchr(feld(x,y));
    next
  next
  print
end sub

dim as t_pipe pipes(num_pipes-1)

locate ,,0
do
  for i as long=0 to num_pipes-1
    pipes(i).update()
  next
  render()
  sleep 10,1
loop until inkey=chr(27)
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re:Bilge pipes

Post by dodicat »

Colour coded.

Code: Select all

Declare Function fbmain() As boolean

End fbmain

Type Point
    As Single x,y,z
    As Ulong col
End Type
Type particle
    As Point position,velocity
End Type

#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#define vct Type<Point>
#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)

Operator + (v1 As Point,v2 As Point) As Point
Return vct(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator -(v1 As Point,v2 As Point) As Point
Return vct(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator
Operator * (f As Single,v1 As Point) As Point 'scalar*point
Return vct(f*v1.x,f*v1.y,f*v1.z)
End Operator

Function length(v As Point) As Single
    Return Sqr(v.x*v.x+v.y*v.y+v.z*v.z)
End Function

Function normalize(v As Point) As Point
    Dim n As Single=length(v)
    If n=0 Then n=1e-20
    Return vct(v.x/n,v.y/n,v.z/n,v.col)
End Function

Sub trace(In() As Point,Outarray() As Point,roundedness As Single=60)
    Redim Outarray(0)
    Dim As particle p:roundedness=roundedness/10
    If roundedness<1 Then roundedness=1
    If roundedness>100 Then roundedness=10
    p.position=In(Lbound(In))
    p.velocity=normalize(Type<Point>(In(Lbound(In)+1)-In(Lbound(In))))
    Redim Preserve Outarray(1 To Ubound(Outarray)+1)
    Outarray(Ubound(Outarray))=Type<Point>(In(Lbound(In)).x,In(Lbound(In)).y)
    Dim As Point f
    For n As Integer=Lbound(In) To Ubound(In)-1
        Do
            Var dist=length(p.position-In(n+1))
            f=(1/(Ubound(In)))*f+normalize(In(n+1)-p.position)
            p.velocity= roundedness*normalize(p.velocity+f)
            p.position=p.position+p.velocity
            Redim Preserve Outarray(1 To Ubound(Outarray)+1)
            Outarray(Ubound(Outarray))=Type<Point>(p.position.x,p.position.y,p.position.z)
            If dist<5*roundedness Then Exit Do
        Loop
    Next n
    Redim Preserve Outarray(1 To Ubound(Outarray)+1)
    Outarray(Ubound(Outarray))=Type<Point>(In(Ubound(In)).x,In(Ubound(In)).y,In(Ubound(In)).z)
    Dim As Ulong rd=240,gr=30,bl=230
    Dim As Single kr=15,kg=-5,kb=10
    For n As Long=Lbound(outarray) To Ubound(outarray)
        rd-=kr
        If rd<20 Then kr=-kr
        If rd>240 Then kr=-kr
        gr+=kg
        If gr>240 Then kg=-kg
        If gr<20 Then kg=-kg
        bl-=kb
        If bl<20 Then kb=-kb
        If bl>240 Then kb=-kb
        outarray(n).col=Rgb(rd,gr,bl)
    Next
End Sub

Sub setuppoints(a() As Point,x As long,y As long,n As long)
    Redim a(0)
    Dim As Point start(1 To 4)={(-10,-10,200),(x+10,-10,200),(x+10,y+10,200),(-10,y+10,200)}
    Var s=IntRange(1,4)
    Redim Preserve a(1 To Ubound(a)+1)
    a(Ubound(a))=start(s)
    Dim As Long irx,iry,irz
    For z As Long=1 To n
        Do
            irx=Intrange(.1*x,x-.1*x)
            iry=IntRange(.1*y,y-.1*y)
            irz=IntRange(-200,200)
        Loop Until incircle((x/2),(y/2),200,irx,iry)=0  
        Redim Preserve a(1 To Ubound(a)+1)
        if z=1 then irz=-200
        a(Ubound(a))=Type(irx,iry,irz)
    Next z
End Sub

Sub Qsort(array() As Point,begin As Long,Finish As Long)
    Dim As Long i=begin,j=finish
    Dim As Point x =array(((I+J)\2))
    While I <= J
        While array(I).z > X .z:I+=1:Wend
            While array(J).z < X .z:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
            Wend
            If J >begin Then Qsort(array(),begin,J)
            If I <Finish Then Qsort(array(),I,Finish)
        End Sub
        
        Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
            Static As Double timervalue,lastsleeptime,t3,frames
            Var t=Timer
            frames+=1
            If (t-t3)>=1 Then t3=t:fps=frames:frames=0
            Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
            If sleeptime<1 Then sleeptime=1
            lastsleeptime=sleeptime
            timervalue=T
            Return sleeptime
        End Function      
        
        Function fbmain() As boolean
            Randomize
            Redim As Point INco_ords()
            Redim As Point OUTco_ords()
            Redim As Point main()
            
            Dim As Integer xres,yres
            Screen 20,32
            Screeninfo xres,yres
            setuppoints(main(),xres,yres,20)
            trace(main(),OUTco_ords(),50)
            Dim As Long acc,fps
            Do
                acc+=1
                If acc>Ubound(OUTco_ords) Then 
                    acc=1:Cls:setuppoints(main(),xres,yres,20)
                    trace(main(),OUTco_ords(),50)
                End If
                Screenlock
                Cls
                Locate 1,1
                Draw String(xres/2-100,10),"Framerate "&fps
                Qsort(OUTco_ords(),Lbound(OUTco_ords),acc)
                For n As Long=Lbound(OUTco_ords) To acc  
                    Var rad=map(200,-200,OUTco_ords(n).z,10,30)
                    Circle(OUTco_ords(n).x,OUTco_ords(n).y),rad,OUTco_ords(n).col,,,,f
                Next
                Screenunlock
                Sleep regulate(65,fps),1
            Loop Until Len(Inkey)
            sleep
            Return 1
        End Function
        
        
         
Post Reply