 Stereogram Algorithms - Oversampling This page shows how to modify the basic stereogram code to incorporate all of the algorithms discussed - smart links, hidden surface removal, and oversampling (I'm working on adding center-out processing - as soon as I figure it out!). ```1 Dim x As Long, y As Long, maxX As Long, maxY As Long, same() As Long 'basic 2 Dim z() As Single, mu As Single, E As Long, DPI As Long, s As Long 'basic 3 Dim right As Long, left As Long, w As Single 'basic 4 Dim L As Long 'smart links 5 Dim zt As Single, t As Long, visible As Long 'hidden surface removal 6 Dim R As Long, G As Long, B As Long, i As Long 'oversampling 7 Dim p() As Long, oversample As Long 'oversampling 8 oversample = 2: DPI = 72: E = 2.5 * DPI * oversample: mu = 0.2: w = 0.5 9 maxX = picDepth.ScaleWidth * oversample: maxY = picDepth.ScaleHeight 10 ReDim same(maxX), z(maxX, maxY), p(maxX, maxY): Randomize 11 For y = 0 To maxY 12 For x = 0 To maxX - 1 '1 scanline 13 z(x, y) = picDepth.Point(x / oversample, y) / 16777215 'initialize 14 same(x) = x 'initialize 15 s = (1 - mu * z(x, y)) * E / (2 - mu * z(x, y)) 'image plane separation 16 left = x - (s / 2) 'left link position 17 right = left + s 'right link position 18 If 0 <= left And right < maxX Then 19 t = 1 20 Do 21 zt = z(x, y) + 2 * (2 - mu * z(x, y)) * t / (mu * E) 22 visible = (z(x - t, y) < zt) And (z(x + t, y) < zt) 23 t = t + 1 24 Loop While visible And (zt < 1) 25 If visible Then 26 L = same(left) 'begin smart links code 27 While (L <> left) And (L <> right) ' 28 If L < right Then ' 29 left = L ' 30 L = same(left) ' 31 Else ' 32 same(left) = right ' 33 left = right ' 34 L = same(left) ' 35 right = L ' 36 End If ' 37 Wend 38 same(left) = right 'create link 39 End If 40 End If 41 Next x 42 For x = maxX - 1 To 0 Step -1 'set colors 43 If same(x) = x Then 44 p(x, y) = Int(Rnd + w) * vbWhite 'Rnd*vbwhite for color 45 Else 46 p(x, y) = p(same(x), y) 'link color 47 End If 48 Next x 49 Next y 50 For y = 0 To maxY: For x = 0 To maxX - 1 Step oversample 'average pixel colors 51 R = 0: G = 0: B = 0 52 For i = 0 To oversample - 1 53 R = R + p(x + i, y) Mod 256 54 G = G + (p(x + i, y) \ 256) Mod 256 55 B = B + (p(x + i, y) \ 256 \ 256) Mod 256 56 Next i 57 picOut.PSet (x / oversample, y), RGB(R / oversample, G / oversample, B / oversample) 58 Next x: Next y ```