hier ein kleiner Code zum generieren einer "Heatmap", wie man es vielleicht von Wetterkarten kennt.
Wenn man den Farbgradienten um Alphawerte erweitert und die Draw()-Funktion mit dem AlphaBlend Modus erweitert, kann z.B. sowas bauen.
Der Code ist gerade erst entstanden, also weder ordentlich kommentiert noch optimiert (bei jedem Click eine "Heatsource" hinzugefügt und alles komplett neu berechnet, das Erstellen der Karte dauert also nach jedem Klick länger).
Ich habe schon einige Ideen, wie das ganze optimiert werden kann.
Zum einen nicht immer alles neuberechnen, sondern das Ergebnis zwischenspeichern und nur mit den neuen Daten nach einem Klick zusammenführen.
Zum anderen diese ganzen Cos/Sin-Berechnungen aus dem Loop rausziehen und einmal für jeden Kreis (gegeben durch Radius und Gradient-Funktion) eine Punktmatrix erstellen.
Und dann halt noch Schönheitskram, wie nicht-hardcoded Farbverläufe, Overlay-Transparenz, Import/Export etc.
Code: Alles auswählen
DeclareModule Heatmap
Structure __struct_Heatmap
width.i
height.i
Array pixelValues.d(1)
EndStructure
Global Dim __ListOfHeatmaps.__struct_Heatmap(100)
Declare Create(width.i, height.i)
Prototype.d pGradient(varRadius_between_0_and_1.d)
Declare NewCircleTemplate(radius, *callback.pGradient )
Declare AddPoint(heatmap, template, x, y, intensity.d=1.0)
EndDeclareModule
Module Heatmap
Structure __struct_circleTemplate
diameter.i
Array pixelValues.d(1)
EndStructure
Global Dim __ListOfCircleTemplates.__struct_circleTemplate(100)
Global __index_ListOfHeatmaps.i
Global __index_ListOfCircleTemplates.i
Procedure Create(width.i, height.i) ; => ID of Heatmap
__ListOfHeatmaps(__index_ListOfHeatmaps)\width = width
__ListOfHeatmaps(__index_ListOfHeatmaps)\height = height
ReDim __ListOfHeatmaps(__index_ListOfHeatmaps)\pixelValues(width*height)
__index_ListOfHeatmaps + 1
ProcedureReturn __index_ListOfHeatmaps - 1
EndProcedure
Procedure NewCircleTemplate(radius, *callback.pGradient)
Protected.i x,y,v,i
Protected alpha.d
Protected r.i
Protected diameter = radius*2
Protected.d radius_normiert
__ListOfCircleTemplates(__index_ListOfCircleTemplates)\diameter = diameter
ReDim __ListOfCircleTemplates(__index_ListOfCircleTemplates)\pixelValues((diameter)*(diameter))
For i = 1 To 3600
alpha + 0.1
;LineXY(circles()\x, circles()\y, circles()\radius * Cos(Radian(alpha)) +circles()\x, circles()\radius * Sin(Radian(alpha)) +circles()\y, $0000FF)
For r=0 To radius
x=Int(Round(r * Cos(Radian(alpha)) + radius, #PB_Round_Nearest))
y=Int(Round(r * Sin(Radian(alpha)) + radius, #PB_Round_Nearest))
v = x + y*diameter
radius_normiert = 1.0*r/radius
;Debug x + y*diameter
If v<=diameter*diameter
__ListOfCircleTemplates(__index_ListOfCircleTemplates)\pixelValues( x + y*diameter) = *callback(radius_normiert)
EndIf
Next
Next
__index_ListOfCircleTemplates + 1
ProcedureReturn __index_ListOfCircleTemplates - 1
EndProcedure
Procedure AddPoint(heatmap, template, PointX, PointY, intensity.d=1.0)
Protected w = __ListOfHeatmaps(heatmap)\width
Protected h = __ListOfHeatmaps(heatmap)\height
Protected A = w*h ; "Area" of Heatmap = Number of Points
Protected d = __ListOfCircleTemplates(template)\diameter
Protected d2 = (d*d)-1 ;-1 because Arrays start at 0
Protected x_orig = PointX-(d/2)
Protected y_orig = PointY-(d/2)
Protected x,y ;x,y within the Template --> x+x_orig = x within the heatmap etc.
Protected i
Protected pointN
For i=0 To d2
If x>=d
x=0
y+1
EndIf
pointN = (y+y_orig)*w + (x+x_orig) ;y within in the Heatmap is line number (y) * width of heightmap.
If pointN >=0 And pointN <A
__ListOfHeatmaps(heatmap)\pixelValues(pointN) + (__ListOfCircleTemplates(template)\pixelValues(y*d + x) * intensity)
EndIf
x+1
Next
EndProcedure
EndModule
;-> EndModule
Procedure.d testGradient(val.d)
ProcedureReturn 1-val
EndProcedure
;{
Global Dim HMG(101)
HMG(000) = RGBA(0,$FF,$4A,0);$000000
HMG(001) = RGBA(0,$FF,$4A,50);$3F1200
HMG(002) = RGBA(0,$FF,$4A,100);$7F2500
HMG(003) = RGBA(0,$FF,$4AF,150);$BF3700
HMG(004) = RGBA(0,$FF,$4A,200);$FF4A00
HMG(005) = $D46803
HMG(006) = $AA8606
HMG(007) = $7FA409
HMG(008) = $55C20C
HMG(009) = $2AE00F
HMG(010) = $00FF12
HMG(011) = $00FF23
HMG(012) = $00FF2C
HMG(013) = $00FF35
HMG(014) = $00FF3D
HMG(015) = $00FF48
HMG(016) = $00FF4F
HMG(017) = $00FF58
HMG(018) = $00FF61
HMG(019) = $00FF69
HMG(020) = $00FF72
HMG(021) = $00FF7B
HMG(022) = $00FF84
HMG(023) = $00FF8C
HMG(024) = $00FF95
HMG(025) = $00FF9E
HMG(026) = $00FFA7
HMG(027) = $00FFB0
HMG(028) = $00FFC1
HMG(029) = $00FFCA
HMG(030) = $00FFD3
HMG(031) = $00FFDB
HMG(032) = $00FFE4
HMG(033) = $00FFED
HMG(034) = $00FFF6
HMG(035) = $00FFFF
HMG(036) = $00FBFF
HMG(037) = $00F7FF
HMG(038) = $00F3FF
HMG(039) = $00EFFF
HMG(040) = $00EBFF
HMG(041) = $00E7FF
HMG(042) = $00E3FF
HMG(043) = $00DFFF
HMG(044) = $00DBFF
HMG(045) = $00D7FF
HMG(046) = $00D3FF
HMG(047) = $00CFFF
HMG(048) = $00CBFF
HMG(049) = $00C7FF
HMG(050) = $00C3FF
HMG(051) = $00BFFF
HMG(052) = $00BBFF
HMG(053) = $00B7FF
HMG(054) = $00B3FF
HMG(055) = $00AFFF
HMG(056) = $00ABFF
HMG(057) = $00A7FF
HMG(058) = $00A3FF
HMG(059) = $009FFF
HMG(060) = $009BFF
HMG(061) = $0097FF
HMG(062) = $0093FF
HMG(063) = $008FFF
HMG(064) = $008BFF
HMG(065) = $0087FF
HMG(066) = $0083FF
HMG(067) = $007FFF
HMG(068) = $007BFF
HMG(069) = $0077FF
HMG(070) = $0073FF
HMG(071) = $006FFF
HMG(072) = $006BFF
HMG(073) = $0067FF
HMG(074) = $0063FF
HMG(075) = $005FFF
HMG(076) = $005BFF
HMG(077) = $0057FF
HMG(078) = $0053FF
HMG(079) = $004FFF
HMG(080) = $004BFF
HMG(081) = $0047FF
HMG(082) = $0043FF
HMG(083) = $003FFF
HMG(084) = $003BFF
HMG(085) = $0037FF
HMG(086) = $0033FF
HMG(087) = $002FFF
HMG(088) = $002BFF
HMG(089) = $0027FF
HMG(090) = $0023FF
HMG(091) = $001FFF
HMG(092) = $001BFF
HMG(093) = $0017FF
HMG(094) = $0013FF
HMG(095) = $000FFF
HMG(096) = $000BFF
HMG(097) = $0007FF
HMG(098) = $0003FF
HMG(099) = $0000FF
HMG(100) = $0000FF
For i=5 To 100
HMG(i) = RGBA(Red(HMG(i)), Green(HMG(i)), Blue(HMG(i)), 100)
Next
;}
Procedure.i myColors(val.d);0=rot, 1=grün
If val>1 : val=1 : EndIf
If val<0 : val=0 : EndIf
ProcedureReturn HMG(Int(val*100))
EndProcedure
Define myHeatmap = Heatmap::Create(500,500)
Define myCircleTemplate = Heatmap::NewCircleTemplate(50, @testGradient())
Heatmap::AddPoint(myHeatmap, myCircleTemplate, 100, 100)
Heatmap::AddPoint(myHeatmap, myCircleTemplate, 100, 100, -1)
UsePNGImageDecoder()
Global img = LoadImage(0, "map_heatmap.png")
Procedure draw()
Protected n, x, y
StartDrawing(CanvasOutput(0))
Box(0, 0, 500, 500, $FFFFFF)
If img
DrawImage(ImageID(0), 0, 0)
EndIf
DrawingMode(#PB_2DDrawing_AlphaBlend )
For n=0 To 249999 ;=500*500 - 1
If x>=500
x=0
y+1
EndIf
Plot( x,y, myColors( Heatmap::__ListOfHeatmaps(myHeatmap)\pixelValues(n) ) )
x+1
Next
StopDrawing()
EndProcedure
OpenWindow(0, 0, 0, 500, 500, "test", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
CanvasGadget(0, 0, 0, 500 , 500)
draw()
Repeat
e=WaitWindowEvent()
If e=#PB_Event_Gadget And EventGadget()=0
If EventType() = #PB_EventType_LeftClick
Heatmap::AddPoint(myHeatmap, myCircleTemplate, GetGadgetAttribute(0, #PB_Canvas_MouseX), GetGadgetAttribute(0, #PB_Canvas_MouseY), 0.25)
draw()
EndIf
If EventType() = #PB_EventType_RightClick
Heatmap::AddPoint(myHeatmap, myCircleTemplate, GetGadgetAttribute(0, #PB_Canvas_MouseX), GetGadgetAttribute(0, #PB_Canvas_MouseY), -0.25)
draw()
EndIf
EndIf
Until e=#PB_Event_CloseWindow
End