Text's particles attraction repulsion
Re: Text's particles attraction repulsion
Tested with Mac OS and Windows 10 and With a classic Logitech mouse. Very nice. Thank you for sharing. ^-^
➽ Windows 11 64-bit - PB 6.0 x64 - AMD Ryzen 7 - NVIDIA GeForce GTX 1650 Ti
Sorry for my bad english and the Dunning–Kruger effect.
- Michael Vogel
- Addict
- Posts: 2666
- Joined: Thu Feb 09, 2006 11:27 pm
- Contact:
Re: Text's particles attraction repulsion
Tried to get rid of the floating calculations (not completely done) which may add a little bit speed, checked also if a simple canvas gadget is quick enough.
Even these things are looking fine, there are two others on the bad side: mouse coordinates are calculated for windows only and not all particles seem to find the way back to their home position when the mouse pointer will be moved around...
Even these things are looking fine, there are two others on the bad side: mouse coordinates are calculated for windows only and not all particles seem to find the way back to their home position when the mouse pointer will be moved around...
Code: Select all
; Define
#Precision=8
#X=800
#Y=300
#Maxspeed= 5<<#Precision
#MaxForce= 1<<#Precision
#FleeAction= 50<<#Precision
#RepulseMagnitude= 5<<#Precision
#DistanceToLand= 20<<#Precision
#DistanceBetweenPoint=10
#FontSize=160
#ParticleSize=2
text$="PureBasic"
If OpenWindow(0, 0, 0, #X, #Y, "Steering Particle Text", #PB_Window_SystemMenu | #PB_Window_ScreenCentered) = 0: MessageRequester("Error", "Can't open windowed screen!", 0): EndIf
CanvasGadget(0,0,0,#x,#y)
Structure vector
x.i
y.i
EndStructure
Structure pt
Pos.vector
Vel.vector
Acc.vector
target.vector
size.i
color.i
EndStructure
Enumeration sprites
#mouse_spr
#point_spr
EndEnumeration
;for addPointsFromImage procedure ;pour la procédure addPointsFromImage
Enumeration -2
#color_random
#color_source
EndEnumeration
Global NewList Pt.pt()
; EndDefine
; Define Vector Functions
Macro DebugVector(text,v)
Debug text+": "+Str(v\x)+" / "+Str(v\y)
EndMacro
Macro SetVector(v,x_,y_)
v\x=x_
v\y=y_
EndMacro
Macro CopyVector(v,a)
a=v
EndMacro
Macro AddVector(v,a)
v\x+a\x
v\y+a\y
EndMacro
Macro SubVector(v,a)
v\x-a\x
v\y-a\y
EndMacro
Macro MulVector(v,val)
v\x*val
v\y*val
EndMacro
Macro LenVector(v)
Int(Sqr((v\x*v\x)+(v\y*v\y)))
EndMacro
Procedure.f SetMagnitudeVector(*V1.vector,magnitude.f)
angle.f=ATan2(*V1\x,*V1\y)
*V1\y=magnitude*Sin(angle)
*V1\x=magnitude*Cos(angle)
EndProcedure
Procedure LimitMagnitudeVector(*V1.vector,limit)
Protected magnitude=LenVector(*V1)
If magnitude>limit
SetMagnitudeVector(*V1,limit)
EndIf
EndProcedure
Procedure RandomVector(*V1.vector,MagnitudeMax)
*V1\x=(Random(2000)-1000)
*V1\y=(Random(2000)-1000)
SetMagnitudeVector(*V1,Random(MagnitudeMax))
EndProcedure
; EndDefine
Procedure UpdateParticlePhysic()
ForEach pt()
With pt()
AddVector(\Pos,\Vel)
AddVector(\Vel,\Acc)
MulVector(\Acc,0)
EndWith
Next pt()
EndProcedure
Procedure Arrive()
Define steer.vector,desired.vector
ForEach pt()
With pt()
CopyVector(\target,desired)
SubVector(desired,\Pos)
distance.f=LenVector(Desired)
MaxSpeed.f=#MaxSpeed
If distance<#DistanceToLand
MaxSpeed=MaxSpeed/(#DistanceToLand-d)
EndIf
SetMagnitudeVector(Desired,MaxSpeed)
CopyVector(desired,Steer)
SubVector(Steer,pt()\vel)
LimitMagnitudeVector(Steer,#MaxForce)
AddVector(\acc,Steer)
EndWith
Next pt()
EndProcedure
Procedure Flee()
Protected Desired.vector
Static oldmouse.vector
Protected mouse.vector
Protected fleespeed
Protected n
GetCursorPos_(mouse)
ScreenToClient_(GadgetID(0),mouse)
MulVector(mouse,1<<#Precision)
SubVector(oldmouse,mouse)
fleespeed=LenVector(oldmouse)
CopyVector(mouse,oldmouse)
If fleespeed>#RepulseMagnitude
fleespeed=#RepulseMagnitude
EndIf
ForEach pt()
CopyVector(mouse,Desired)
SubVector(Desired,pt()\Pos)
If LenVector(Desired)<#FleeAction
SetMagnitudeVector(Desired,-fleespeed)
AddVector(pt()\acc,Desired)
SubVector(Desired,pt()\vel)
LimitMagnitudeVector(Desired,#MaxForce)
EndIf
Next pt()
EndProcedure
;filter drawing into equally spaced points specified by filterDistanceBetweenPoint ;Filtrage en points équidistants spécifiés par filterDistanceBetweenPoint
Procedure filterDraw(x, y, sourcecolor, targetcolor)
Shared filterDistanceBetweenPoint
If x % filterDistanceBetweenPoint = 0 And y % filterDistanceBetweenPoint = 0
ProcedureReturn targetcolor
Else
ProcedureReturn 0
EndIf
EndProcedure
;Add a particle for each points of the text/ajoute une particule pour chacun de ces point
Procedure addPointsFromImage(List pt.pt(), image, xmin, ymin, xmax, ymax, size = #ParticleSize, x_dst = 0, y_dst = 0, color = #color_random)
Protected i, j
If StartDrawing(ImageOutput(image))
For j = ymin To ymax
If j > OutputHeight() - 1: Continue: EndIf
For i = xmin To xmax
If i > OutputWidth() - 1: Continue: EndIf
If Point(i, j) <> 0
AddElement(pt())
pt()\pos\x = Random(#X)<<#Precision; Random(x_dst + xmax)<<#Precision
pt()\pos\y = Random(#Y)<<#Precision; Random(y_dst + ymax)<<#Precision
pt()\target\x = (x_dst + i)<<#Precision
pt()\target\y = (y_dst + j)<<#Precision
RandomVector(pt()\vel, 10)
pt()\size = size
Select color
Case #color_random
pt()\color = RGB(Random(255), Random(255), Random(255))
Case #color_source
pt()\color = Point(i, j)
Default
pt()\color = color
EndSelect
EndIf
Next i
Next j
StopDrawing()
EndIf
EndProcedure
Define filterDistanceBetweenPoint = #DistanceBetweenPoint
;{ Transform text$ in a vector points shape. /transforme le text$ en une série de points
CreateImage(0,#X,#Y)
LoadFont(0, "Arial", 20, #PB_Font_Bold)
If StartVectorDrawing(ImageVectorOutput(0,#PB_Unit_Pixel))
VectorFont(FontID(0),#fontSize)
large=VectorTextWidth(Text$)
Haut=VectorTextHeight(Text$)
ox=(#X-large)>>1
oy=(#Y-haut)>>1
MovePathCursor(ox,oy)
AddPathText(Text$)
VectorSourceColor(RGBA(255, 0, 0, 255))
FillPath()
StopVectorDrawing()
If StartDrawing(ImageOutput(0)) ;filter image to equally spaced points ;filtre l'image sur des points équidistants
filterDistanceBetweenPoint = #DistanceBetweenPoint / 3
DrawingMode(#PB_2DDrawing_CustomFilter)
CustomFilterCallback(@filterDraw())
Box(ox,oy,large, haut, RGB(255, 0, 0))
StopDrawing()
EndIf
addPointsFromImage(pt(),0,ox,oy,ox+large,oy+Haut, 5)
EndIf
If StartVectorDrawing(ImageVectorOutput(0, #PB_Unit_Pixel))
MovePathCursor(0,0)
AddPathBox(0,0,VectorOutputWidth(), VectorOutputHeight())
VectorSourceColor(RGBA(0,0,0,255))
FillPath()
VectorFont(FontID(0),#fontSize)
MovePathCursor(ox,oy)
AddPathText(Text$)
VectorSourceColor(RGBA(255, 0, 0, 255))
DotPath(1,#DistanceBetweenPoint/4)
StopVectorDrawing()
addPointsFromImage(pt(),0,ox,oy,ox+large,oy+Haut, 5, 0,0,RGB(255, 0, 0))
EndIf
FreeImage(0)
If LoadImage(0, #PB_Compiler_Home + "\Examples\Sources\Data\PureBasicLogo.bmp")
addPointsFromImage(pt(), 0, 0, 0, ImageWidth(0), ImageHeight(0), 1, 0,#y - ImageHeight(0), #color_source)
FreeImage(0)
EndIf
If LoadImage(0, #PB_Compiler_Home + "\Examples\Sources\Data\GeeBee2.bmp")
If StartDrawing(ImageOutput(0))
;filter image to equally spaced points ;filtre l'image sur des points équidistants
filterDistanceBetweenPoint = #DistanceBetweenPoint / 4
DrawingMode(#PB_2DDrawing_CustomFilter)
CustomFilterCallback(@filterDraw())
Box(0, 0, ImageWidth(0), ImageHeight(0), RGB(255, 0, 0))
StopDrawing()
EndIf
addPointsFromImage(pt(), 0, 0, 0, ImageWidth(0), ImageHeight(0), 3, #x - ImageWidth(0),#y - ImageHeight(0), #color_source)
FreeImage(0)
EndIf
;}
Repeat
Arrive()
Flee()
UpdateParticlePhysic()
StartDrawing(CanvasOutput(0))
Box(0,0,#X,#y,0)
ForEach pt()
Box(pt()\pos\x>>#Precision, pt()\pos\y>>#Precision,#ParticleSize,#ParticleSize,pt()\color)
Next
StopDrawing()
Until WindowEvent()=#PB_Event_CloseWindow
Re: Text's particles attraction repulsion
Really a great effect. The initial post works fine here on Linux, too. Impressive
The variants of Michael Vogel and Demivec do not work on my Linux machine (KDE Neon, PB 5.46 LTS). No cross-platform compatibility any more (Win API or only black screen).
The variants of Michael Vogel and Demivec do not work on my Linux machine (KDE Neon, PB 5.46 LTS). No cross-platform compatibility any more (Win API or only black screen).
- Kwai chang caine
- Always Here
- Posts: 5342
- Joined: Sun Nov 05, 2006 11:42 pm
- Location: Lyon - France
Re: Text's particles attraction repulsion
Amazing !!!
Works great here W7 sp1 / v5.62 x86
Thanks for sharing
Works great here W7 sp1 / v5.62 x86
Thanks for sharing
The happiness is a road...
Not a destination
Not a destination