Contour Map from Data

-=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- (c) WidthPadding Industries 1987 0\|534\|0 -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=-
SoCoder -> Snippet Home -> Misc

Andy_A	Created : 15 September 2016 Language : Blitz Contour Map from Data Makes a contour map!
I found this on the QB64 forum. It's a really nice and compact way to create a contour map from just a handful of data points. There seems to be quite a few practical uses for this type of code. Here's a simple use: However, it can be very slow, if you use a large screen res with lots of data points (loops nested 4 deep). As it is now, with 23 data points at 640x480 res, it takes about 20 seconds on my slow laptop. ;https://www.qb64.net/forum/index.php?topic=3714.msg37019#msg37019 ;https://en.wikipedia.org/wiki/Richard_V._Southwell ;https://en.wikipedia.org/wiki/Relaxation_(iterative_method) ;============================================================ ; Contour map directly from data points by Mrwhy ;============================================================ ; B+ version by Andres Amaya Jr - 2016 ;============================================================ AppTitle "Contour Map by Mrwhy - Click to exit" Const sw% = 640 Const sh% = 480 Graphics sw, sh, 32, 2 SetBuffer BackBuffer() SeedRnd MilliSecs() Dim pal%(47,2), fx#(50), fy#(50), iz#(100), E#(50), h#(640, 480) Gosub setPalette Local i#, ztot#, n#, zmean#, wo#, w#, emax# Local k#, dx#, dy#, dsq#, ii#, x#, y#, dsq2#, et# Local numPoints%, st%, jj%, col% Restore heightData Read numPoints For i = 1 To numPoints Read fx(i),fy(i),iz(i) Color 255,255,255 Text fx(i)-8, fy(i)-16, Str(Int(iz(i))) Color pal(iz(i-1),0), pal(iz(i-1),1), pal(iz(i-1),2) Oval fx(i)-4, fy(i) - 4, 8, 8, True Color 0,0,0 Oval fx(i)-2, fy(i) - 2, 4, 4, True ztot = ztot + iz(i) Next n = numPoints zmean = ztot / n wo = Float(sw) * Float(sh) / n w = wo/2.0 legend(47) Color 255,255,255 msg$ = "Calculating contour plot" Text 50,0,msg$ tx = StringWidth(msg$)+50 Flip st = MilliSecs() For i = 1 To n E(i) = Float(iz(i)) - zmean Next chk% = 9 * n / 10 For jj = 1 To 9 * n ;find max error point emax = 0.0 For i = 1. To n If Abs(E(i)) > emax Then emax = Abs(E(i)): ii = i k = E(ii) Next ;fixit For i = 1 To n dx = fx(i) - fx(ii) dy = fy(i) - fy(ii) dsq = dxdx + dydy E(i) = E(i) - k * Exp(-(dsq / w)) If i = ii Then For y = 1 To sh-1 For x = 1 To sw-1 dx = x - fx(ii) dy = y - fy(ii) dsq2 = dxdx + dydy h(x, y) = h(x, y) + k * Exp(-(dsq2 / w)) Next If KeyHit(1) Then End Next End If Next If jj Mod chk = 0 Then Text tx, 0,"." Flip tx = tx + 6 End If Next For y = 1 To sh-1 For x = 1 To sw-1 col = h(x, y) + Int(zmean) Color pal(col,0), pal(col,1), pal(col,2) Rect x-1, y-1, 3, 3, True Next If KeyHit(1) Then End Next et = (MilliSecs()-st)/1000.0 legend(47) Color 0,0,0 Text 50, sh-15, "et: "+et For i = 1 To n Color 0,0,0 Text fx(i)-8, fy(i)-16, Str(Int(iz(i))) Oval fx(i)-3, fy(i)-3, 6, 6, True Color pal(iz(i),0), pal(iz(i),1), pal(iz(i),2) Oval fx(i)-2, fy(i)-2, 4, 4, True Next Flip WaitMouse() End Function legend(colorMax%) iy = 0 Color 0,0,0 Rect 0,0,40,sh,True For id% = 0 To colorMax Color 255,255,255 If id < 10 Then istr$ = " "+Str(id) Else istr$ = Str(id) End If Text 0, iy, istr$ Color pal(id,0),pal(id,1),pal(id,2) Rect 18,iy+2, 22, 6,True iy = iy + 10 Next End Function .heightData Data 23 ;number of data points Data 279,220,11 ;1 Data 160,160,29 ;2 Data 80,80,36 ;3 Data 144,40,27 ;4 Data 350,158,34 ;5 Data 356,248,37 ;6 Data 280,347,29 ;7 Data 387,77,13 ;8 Data 130,230,12 ;9 Data 270,120,29 ;10 Data 360,320,28 ;11 Data 140,270,11 ;12 Data 530,300,36 ;13 Data 450,110,29 ;14 Data 380,370,12 ;15 Data 270,270,10 ;16 Data 600,40,15 ;17 Data 60,440,16 ;18 Data 195,81,17 ;19 Data 206,196,18 ;20 Data 196,110,15 ;21 Data 198,306,20 ;22 Data 399,229,21 ;23 .setPalette Restore rbw48 For i = 0 To 47 Read co% pal(i,0) = co Shr 16 And 255 pal(i,1) = co Shr 8 And 255 pal(i,2) = co And 255 Next Return .rbw48 Data $0000FF,$2000FF,$4000FF,$6000FF,$8000FF,$A000FF,$C000FF,$E000FF Data $FF00FF,$FF00E0,$FF00C0,$FF00A0,$FF0080,$FF0060,$FF0040,$FF0020 Data $FF0000,$FF2000,$FF4000,$FF6000,$FF8000,$FFA000,$FFC000,$FFE000 Data $FFFF00,$E0FF00,$C0FF00,$A0FF00,$80FF00,$60FF00,$40FF00,$20FF00 Data $00FF00,$00FF20,$00FF40,$00FF60,$00FF80,$00FFA0,$00FFC0,$00FFE0 Data $00FFFF,$00E0FF,$00C0FF,$00A0FF,$0080FF,$0060FF,$0040FF,$0020FF[imgs]null[/imgs] --v

Comments
Friday, 16 September 2016, 18:14
HoboBen	Ooooh neat!

Comments