Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Shaded / contour plot routine for 2D arrays - Artist version

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Shaded / contour plot routine for 2D arrays - Artist version

    When writing this routine for a serious purpose, i sometimes stumbled upon
    unintended but beautiful graphic effects.

    In case someone is interested in this, some examples are presented here.



    Code:
    [FONT=Courier New][SIZE=3]' ---------------------------------------------------------------------------[/SIZE][/FONT]
     
    [SIZE=3][FONT=Courier New]'                     SHADED / CONTOUR PLOTS FROM 2D ARRAYS[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]'                                Artist version[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]'                                   for PBCC[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]'                          Arie Verheul - october 2008[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' When writing this routine for a serious purpose, i sometimes stumbled upon[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]' unintended but beautiful graphic effects.[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]' In case someone is interested in this, some examples are presented here.[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' The code is virtually identical to that of the technical version, except that[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]' two color modes for pseudo random colouring were added.[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]' Also note that the examples presented here use exactly the same model that[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]' was used in the technical version. This demonstrates the effect of presentation[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]' on the impression obtained from otherwise exact procedures.[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]#Compiler PBCC 4.04[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]#Compile Exe[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]#Dim All[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]#Console Off[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Type ContourParmset[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] NumColor  As Long       ' Number of shades in positive and negative half of range[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] PlotRange As Single     ' Maximum value to be rendered (positive value)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ContInt   As Single     ' Contour interval, in same units as PlotRange (positive value)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Mode      As Long       ' Specifies type of colouring, 1 = proportional colouring[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]                         '                              2 = pseudo random intensity[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]                         '                              3 = pseudo random colouring[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ArrayMax  As Single     ' Maximum and minimum values, determined internally[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ArrayMin  As Single[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]End Type[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Declare Sub      FiniteDifference   (PlotArray() As Single)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]Declare Sub      DetermineExtremes  (PlotArray() As Single, PlotParms As ContourParmset)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]Declare Sub      MapArrayToWindow   (PlotArray() As Single, ScreenArray() As Single)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]Declare Sub      ColorPlot          (ScreenArray() As Single, PlotParms As ContourParmset)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Declare Function IsWindow Lib "USER32.DLL" Alias "IsWindow" (ByVal hWnd As Dword) As Long[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Function PBMain () As Long[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Local hWnd         As Dword[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local N            As Long[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local WindowTitle  As String[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Dim ScreenArray () As Single[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Dim PlotArray()    As Single[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Dim PlotParms      As ContourParmset[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' Main program[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] FiniteDifference PlotArray()                ' Produce some data to be plotted[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] DetermineExtremes PlotArray(), PlotParms    ' Determine Max/Min values[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' Plot settings (may be changed)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] PlotParms.PlotRange = 500[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] PlotParms.ContInt   =  50[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] For N = 1 To 6[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     ' Variable plot settings (may be changed)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     PlotParms.NumColor = Choose&(N,40,20,10,5,100,50)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     PlotParms.Mode     = Choose&(N,1,1,2,2,3,3)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     WindowTitle        = Choose$(PlotParms.Mode,"Proportional colouring -",_[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]                                  "Pseudo random intensity -",_[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]                                  "Pseudo random colouring -")[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     WindowTitle = WindowTitle + Str$(PlotParms.NumColor) +_[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]                   " colors - close window to continue"[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     Graphic Window WindowTitle,200,100,600,600 To hWnd[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     Graphic Attach hWnd, 0[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     Graphic Color  %White, %Black[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     Graphic Clear[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     MapArrayToWindow PlotArray(), ScreenArray() ' Calculate interpolated values for each pixel[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     ColorPlot ScreenArray(), PlotParms          ' Translate values to shades[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     While IsWindow(hWnd): Sleep 1000: Wend      ' Proceed after window closure[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Next[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]End Function[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Sub FiniteDifference (PlotArray() As Single)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' The purpose of this Sub is just to produce some data to be plotted[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' It must not be considered as a good or general example to use this algorithm[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] %NumInt = 100[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Local N, M, I As Long[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local XS1, XS2, XS3, YS1, YS2, YS3 As Long[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ReDim PlotArray(%NumInt,%NumInt) As Single[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' Set internal boundaries[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] XS1 = .2 * %NumInt              ' Location of internal boundary points[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] XS2 = %NumInt - XS1[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] YS1 = .2 * %NumInt[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] YS2 = %NumInt - YS1[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] XS3 = %NumInt / 2[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] YS3 = %NumInt / 2[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] PlotArray(XS1,YS1) =   1250     ' Values assigned to internal boundary points[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] PlotArray(XS2,YS2) =   1250[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] PlotArray(XS1,YS2) = - 1375[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] PlotArray(XS2,YS1) = - 1375[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] PlotArray(XS3,YS3) =   1125[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] For I = 1 To 2000                  ' Iterations[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     For M = 1 To %NumInt - 1       ' Vert. direction[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         For N = 1 To %NumInt - 1   ' Hor. direction[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]             If M = YS1 Or M = YS2 Then[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]                 If N = XS1 Or N = XS2 Then Iterate For  ' Skip internal boundary points[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]             End If[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]             If M = YS3 And N = XS3 Then Iterate For[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]             PlotArray(N,M) = (PlotArray(N-1,M) + PlotArray(N+1,M)_[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]                              + PlotArray(N,M-1) + PlotArray(N,M+1)) / 4[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         Next[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     Next[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Next[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]End Sub[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Sub DetermineExtremes (PlotArray() As Single, PlotParms As ContourParmset)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' Determines Maximum and Minimum value in Plotarray()[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Local M, N As Long[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local TestValue, ArrayMax, ArrayMin As Single[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ArrayMin = PlotArray(0,0)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ArrayMax = ArrayMin[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] For M = 0 To UBound(PlotArray, 2)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     For N = 0 To UBound(PlotArray, 1)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         TestValue = PlotArray(N,M)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         'Skip poles, if present[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         If (TestValue > 1E35) Or (TestValue < -1E35) Then Iterate For[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         ArrayMax = Max(TestValue, ArrayMax)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         ArrayMin = Min(TestValue, ArrayMin)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     Next[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Next[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] PlotParms.ArrayMax = ArrayMax[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] PlotParms.ArrayMin = ArrayMin[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]End Sub[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Sub MapArrayToWindow (PlotArray() As Single, ScreenArray() As Single)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' This sub calculates linearly interpolated values from PlotArray()[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' for each pixel in ScreenArray()[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' Note: in the following the rectangular area enclosed by[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' four neighbouring gridpoints is designated as an element[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Local WindowWidth, WindowHeight As Long[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local Xmax, Ymax As Long[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local I, ElementRow, Pix, PixRow, CurrentRow As Long[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local X, PixRowPos, VertIntFactor As Single[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Graphic Get Client To WindowWidth, WindowHeight[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Xmax = UBound(PlotArray(),1)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Ymax = UBound(PlotArray(),2)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Dim TopRow(Xmax)               As Single   ' Top nodes of current element row[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Dim BotRow(Xmax)               As Single   ' Bottom nodes of current element row[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Dim RowDiff(Xmax)              As Single   ' Differential (TopRow() - BotRow)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Dim InterpRow(Xmax)            As Single   ' Interpolated values for position of pixel row[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Dim ElDiff(Xmax - 1)           As Single   ' Hor. differential in InterpRow()[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Dim HorIntNumber (WindowWidth) As Long     ' Element to use for interpolation for specific pixel[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Dim HorIntFactor (WindowWidth) As Single   ' Interpolation factor for specific pixel[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ReDim ScreenArray (1 To WindowWidth, 1 To WindowHeight) As Single[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' Make tables for pixel locations and interpolation factors in element grid coordinates[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' in horizontal direction; these tables are valid for each row of pixels.[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] For Pix = 1 To WindowWidth          ' For each pixel in horizontal row[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     X = Pix * Xmax / WindowWidth    ' > Pixel position in element grid coordinates[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     HorIntNumber (Pix) = Int  (X)   ' > Element where pixel is located[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     HorIntFactor (Pix) = Frac (X)   ' > Interpolation factor within element[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Next[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' Do the actual interpolation, working row by row[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] CurrentRow = -1                                  ' Counter to keep track of current element row[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] For PixRow = 1 To WindowHeight                   ' Work row by row[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     PixRowPos = Ymax * PixRow / WindowHeight     ' Vertical position of pixel row[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]                                                  ' in element grid coordinates[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     ElementRow    = Int  (PixRowPos)             ' Element row to use for interpolation[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     VertIntFactor = Frac (PixRowPos)             ' Interpolation factor[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     If ElementRow <> CurrentRow Then             ' If interpolation has reached next[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]                                                  ' element row then data must be refreshed[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         ' Full row of data is extracted from PlotArray() by placing 1D array on top of it[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         ' Using MAT these data are manipulated with a full row at the time[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         ReDim TopRow(Xmax) As Single At VarPtr (PlotArray(0, ElementRow + 1))[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         ReDim BotRow(Xmax) As Single At VarPtr (PlotArray(0, ElementRow))[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         Mat   RowDiff() = TopRow() - BotRow()    ' Vertical differentials[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         CurrentRow = ElementRow[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     End If[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     Mat    InterpRow () = (VertIntFactor) * RowDiff()[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     Mat    InterpRow () = BotRow() + InterpRow()[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     ' InterpRow() now contains an interpolated row of data from PlotArray()[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     ' at PixRowPos, the position of the row of pixels that is treated currently.[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     ' Next within this row the differentials are calculated, and stored in ElDiff()[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     For I = 0 To Xmax - 1           ' Horizontal differential in InterpRow()[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         ElDiff(I) = InterpRow(I + 1) - InterpRow(I)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     Next[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     ' From InterpRow() and ElDiff() the values for each pixel are calculated[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     For Pix = 1 To WindowWidth      ' Work along a row of pixels[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         I = HorIntNumber(Pix)       ' Element where pixel is located[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]         ScreenArray(Pix, PixRow) = InterpRow(I) + ElDiff(I) * HorIntFactor(Pix)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     Next        ' Next pixel[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Next            ' Next row of pixels[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]End Sub[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Sub ColorPlot (ScreenArray() As Single, PlotParms As ContourParmset)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' This sub translates values associated with pixels into shades[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Local R,G,B As Integer[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local N, M, ColorIndex As Long[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local ColorScaleUBound, ColorScaleLBound As Long[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local WindowWidth, WindowHeight As Long[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local X, NormalisedIndex, NormalisedIndexSqr As Single[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Local WindowMap As String[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Dim   PixelPtr As Long Pointer[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' Set default values if necessary[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] If PlotParms.NumColor <= 0 Then PlotParms.NumColor = 300[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] PlotParms.PlotRange    = Abs(PlotParms.PlotRange)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] If PlotParms.PlotRange = 0 Then[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]    PlotParms.PlotRange = Max(Abs(PlotParms.ArrayMax), Abs(PlotParms.ArrayMin))[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] End If[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] PlotParms.ContInt      = Abs(PlotParms.ContInt)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] If PlotParms.ContInt   = 0 Then PlotParms.ContInt = PlotParms.PlotRange / 20[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ColorScaleUBound =  PlotParms.NumColor + 1[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ColorScaleLBound = -PlotParms.NumColor - 1[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Dim Shade(ColorScaleLBound To ColorScaleUBound) As Long[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' color table for proportional colouring (Mode 1) involves the following steps:[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' a. a fractional value <NormalisedIndex> is calculated from the color number.[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' b. using the expression contained in ColorAlgorithm the "positive" shading.[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] '    colors are calculated (BGR format).[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' c. swapping R and B value gives "negative" shading colors.[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' d. contour colors are obtained by adding .35 to <NormalisedIndex>.[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] '    which shifts them to a brighter value.[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' e. if <NormalisedIndex> > 1 then white is used for contours.[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' f. "zero" contour is assigned dark gray.[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' g. at both sides of the color scale an overflow color, dark green, is added.[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' for pseudo random intensity (Mode 2) intensities are asigned pseudo random[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' but in such a way that "positive" colors remain reddish, and "negative" colors[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' remain blueish.[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' for pseudo random colouring (Mode 3) colors are assigned pseudo random,[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' but "negative" colors are still obtained from "positive" ones by swapping R and B.[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' background colors[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Select Case PlotParms.Mode[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     Case 1[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         For N = 1 To PlotParms.NumColor[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]             NormalisedIndex = N / PlotParms.NumColor[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]             GoSub ColorAlgorithm[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         Next[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]             GoSub ContourColors[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     Case 2[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         For N = 1 To PlotParms.NumColor[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]             GoSub PseudoRandomIntensity[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         Next[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     Case 3[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         For N = 1 To PlotParms.NumColor[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]             GoSub PseudoRandomColor[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         Next[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] End Select[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Shade(0) = RGB(80,80,80)            ' "zero" contour[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Shade( PlotParms.NumColor + 1) = RGB(0,80,0)  ' clipped areas[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Shade(-PlotParms.NumColor - 1) = RGB(0,80,0)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] ' GRAPHIC GET BITS / GRAPHIC SET BITS is used here because it is[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] ' much faster than GRAPHIC SET PIXEL[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Graphic Get Client To WindowWidth, WindowHeight[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Graphic Get Bits To WindowMap       ' Get copy of video memory[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] PixelPtr = StrPtr(WindowMap) + 8    ' First two Long Int. contain size[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] For M = WindowHeight To 1 Step -1   ' Origin at left bottom corner[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]                                     ' For origin at left top corner reverse scanning direction[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     For N = 1 To WindowWidth[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     ColorIndex = ScreenArray(N,M) * (PlotParms.NumColor/PlotParms.PlotRange)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     ' overflow check[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     ColorIndex = Min(ColorIndex, ColorScaleUBound)[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     ColorIndex = Max(ColorIndex, ColorScaleLBound)[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     @PixelPtr = Shade(ColorIndex)   ' Write color to Windowmap[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     Incr PixelPtr[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     Next[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Next[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Graphic Set Bits WindowMap          ' Put modified WindowMap back[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Exit Sub[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]ColorAlgorithm:[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] NormalisedIndexSqr = NormalisedIndex^2[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] R = 600 * NormalisedIndex - 345 * NormalisedIndexSqr   ' color expression[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] G = 255 * NormalisedIndexSqr[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] B =   0[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Shade (N) = RGB(B,G,R)              ' BGR color format[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Shade(-N) = RGB(R,G,B)              ' for "negative" colors swap R and B[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Return[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]ContourColors:[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] For X = 0 To PlotParms.PlotRange Step PlotParms.ContInt[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     NormalisedIndex = X / PlotParms.PlotRange[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     N               = NormalisedIndex * PlotParms.NumColor[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     NormalisedIndex = NormalisedIndex + .35[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]     If NormalisedIndex <= 1 Then    ' the above line may produce values > 1[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         GoSub ColorAlgorithm[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     Else[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         Shade (N) = %White          ' use white instead[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]         Shade(-N) = %White[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New]     End If[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Next[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Return[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]PseudoRandomIntensity:[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] R = 255*Rnd()[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] G =  32*Rnd()[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] B =  0[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Shade (N) = RGB(B,G,R)              ' BGR color format[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Shade(-N) = RGB(R,G,B)              ' for "negative" colors swap R and B[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Return[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]' ---------------------------------------------------------------------------[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]PseudoRandomColor:[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] R = 255*Rnd()[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] G = 255*Rnd()[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] B = 255*Rnd()[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New] Shade (N) = RGB(B,G,R)              ' BGR color format[/FONT][/SIZE]
    [SIZE=3][FONT=Courier New] Shade(-N) = RGB(R,G,B)              ' for "negative" colors swap R and B[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]Return[/FONT][/SIZE]
     
    [SIZE=3][FONT=Courier New]End Sub[/FONT][/SIZE]

  • #2
    Stunning!

    Comment

    Working...
    X