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

Laplacian Graphics - A color pattern generator for PBCC

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

  • Laplacian Graphics - A color pattern generator for PBCC

    Laplacian Graphics - A color pattern generator for PBCC



    The code presented here produces graphic images for artistic or entertaining purposes from numerical models.
    It is based on the "Shaded/Contourplot for Artists" routine, which was reworked and extended to a practical applicaton.
    With the code comes a guide for the ignorant user, and a manual describing all background involved. A separate file with 10 example models is also added.

    The code is marked as "Public domain" and may be freely used and distributed for non-commercial purposes, provided that the user assumes any risk that might be involved in this.
    The application is also highly recommended to pass a rainy sunday.

    The application should not be started from a DOS prompt, but from Explorer instead.
    With thanks to Patrice Terrier for his comment (see below).

    Revision november 19, 2008 : Compatibility issues with PBCC 5 corrected.
    With thanks to Paul Dixon (see below)



    Code:
    '
    '                         PAINTING WITH THE LAPLACIAN
    '
    '                                Arie  Verheul
    '                                november 2008
    '
    '
    ' -------------------------------------------------------------------------------
    '
    '                 This information is donated to the Public Domain.
    '
    ' It may be freely used and distributed for non-commercial purposes, proveded that
    ' the user assumes any risk that might be involved in doing so.
    '
    ' -------------------------------------------------------------------------------
    '
    '                              GENERAL USER GUIDE
    '
    ' -------------------------------------------------------------------------------
    '
    ' This application can be used to make beautiful pictures from mathematical models.
    '
    ' Step 1. In the menu click on "Select model". A new window will open with the
    '         names of the models that are with the application. Select one of them.
    '
    ' Step 2. Click on the "PAINT" caption in the menu.
    '         The application will start coloring the picture.
    '
    ' Step 3. To continue coloring with a different scheme, press ENTER or the left
    '         Mouse button, which will bring back the menu.
    '         To just pause the application, press SPACE.
    '         Pressing SPACE again will let the application continue.
    '
    ' Step 4. The menu has several settings that control the way coloring is done.
    '         In the top half of the menu there are captions that may be selected.
    '         In the lower half values may be typed in.
    '         Just try what these controls are doing. It is possible to continue
    '         coloring with still new settings in always the same picture.
    '
    ' Step 5. It may happen that the background does not match with the picture.
    '         If this is the case, click on the 'Set BG Color' caption.
    '         From the color dialog box a different background may be selected.
    '         This will not erase the picture.
    '
    ' Step 6. If a really good picture came out, it may be saved to disk.
    '         To do this, click on the 'Save to BMP' caption.
    '         The application will report that the picture has been saved.
    '
    '  To exit the application click on the 'X icon' at the right top of the menu,
    '  or press Alt-F4.
    '
    ' -------------------------------------------------------------------------------
    '
    '                            TECHNICAL DESCRIPTION
    '
    ' -------------------------------------------------------------------------------
    ' GENERAL PRINCIPLE
    ' -------------------------------------------------------------------------------
    '
    '
    ' This software uses solutions of the Laplacian to produce graphic images.
    ' For those unfamiliar with this operator, it may probably best be understood by
    ' imagining an elastic membrane that is fixed to a rectangular frame.
    ' If poles are placed under this membrane, they may push it up or pull it down.
    ' The Laplacian describes in this case the deflections of the membrane.
    ' This approach was actually used to study Laplace problems before the advent of
    ' computers.
    '
    ' Approximated solutions of the Laplacian may be obtained with the "Finite Diffe-
    ' rence" algorithm. This is a very simple and robust algorithm which, for rectan-
    ' gular coordinates and equal gridspacing in both directions, involves the repeated
    ' adjustment of the value at each gridpoint to the average of its four neighbours
    ' (except for the boundary points).
    '
    ' To present the results of such a calculation it is common practice to draw height
    ' contours, like on a topographic map, and color the enclosed areas accordingly.
    ' In fact this software originated as an accidental spinoff of such an application.
    ' In this case however the coloring is randomised, which means that the colors
    ' have lost their technical function of representing results, whilst just the shapes
    ' of the contours are preserved. These shapes, disconnected from their technical
    ' meaning, may produce beautiful results.
    '
    ' Although there are many mathematical functions and algorithms that can be used to
    ' produce graphic effects, the charm of this approach is that it allows a detailed
    ' input from the user, whilst on the other hand the algorithm is so robust that it
    ' will not be upset by any unusual input.
    '
    '
    ' -------------------------------------------------------------------------------
    ' PROGAM CONTROLS
    ' -------------------------------------------------------------------------------
    '
    ' In the graphic mode there is no visible menu.
    ' Press ENTER or LeftMouse to bring up a menu.
    ' To pause application execution press SPACE.
    '
    '
    ' -------------------------------------------------------------------------------
    ' MODEL SELECTION
    ' -------------------------------------------------------------------------------
    '
    ' The models that provide the input for the Finite Difference algorithm are loca-
    ' ted in an external model file, that may be edited and extended by the user.
    ' Clicking the 'Select model' caption in the main menu will bring up a pick box,
    ' from which a model may be selected with the mouse.
    '
    '
    ' -------------------------------------------------------------------------------
    ' COLOR SETTING
    ' -------------------------------------------------------------------------------
    '
    ' Five options are available, that offer color schemes which are (pseudo) random
    ' to a varying degree :
    '
    '
    '     1. Random 3 colors    Both color and intensity are random.
    '
    '     2. Random 2 colors    Colors have two randomly selected components.
    '
    '     3. Red + green        Colors are composed of only red and green
    '
    '     4. Red + blue         Colors are composed of only red and blue
    '
    '     5. Blue + green       Colors are composed of only blue and    green
    '
    '
    ' If 'Pastel white content' (see below) is set to zero, all 2 color modes result
    ' in saturated colors.
    '
    ' Colors may be modified with two options that can be used in a cumulative way.
    '
    ' UNIFORM BRIGHTNESS        The brightness of the resulting color is always
    '                           adjusted to a preset value.
    '
    ' PASTEL WHITE CONTENT      Specifies a lower limit to the randomising process,
    '                           which results in pastel like colors.
    '                           Values 0 to 99 may be entered.
    '
    ' -------------------------------------------------------------------------------
    ' BACKGROUND COLOR
    ' -------------------------------------------------------------------------------
    '
    ' It is at any moment possible to change the background color without erasing the
    ' picture. Clicking the 'Set BG Color' caption will bring up the well known
    ' Windows color dialog box.
    '
    '
    ' -------------------------------------------------------------------------------
    ' COMPOSITION
    ' -------------------------------------------------------------------------------
    '
    ' The math involved may produce both positive and negative values.
    ' The COMPOSITION setting specifies the way in which shades assigned to positive
    ' and negative values will be related. It may bring some sort of harmony in the
    ' picture, if different parts of it are related in a way that is not immediately
    ' clear, but which is obviously there, just like this is commonly done in music.
    '
    ' The mentioned relations are obtained by swapping and rotating color components.
    ' This gives five options:
    '
    '     Rotate right
    '     Rotate left
    '     Swap R and G
    '     Swap R and B
    '     Swap B and G
    '
    '
    ' Additionally there is a mode where positive and negative shades are complementary
    ' (producing white when added), and a mode where they are fully independent.
    '
    ' -------------------------------------------------------------------------------
    ' SPACING
    ' -------------------------------------------------------------------------------
    '
    ' Instead of filling the picture in a consecutive way, it may be more attractive to
    ' use a walking method. Therefore the range of contour zones is divided into blocks
    ' of 12, and in each round of the process one zone in each block is colored.
    '
    ' Optionally it is possible to color not the whole plot, but just every 2nd, 3rd,
    ' 4th, 5th, 6th or 12th zone in each block.
    ' This gives the option of zebra like patterns.
    '
    ' But as it is at all times possible to change the settings, it offers also the
    ' option to work like a conventional painter does, and continue coloring in an
    ' existing picture with new settings.
    '
    ' Interesting results may be obtained by first coloring a large area in a small
    ' number of colors, and subsequently adding some thin lines by increasing the
    ' number of zones and simultaneously increasing the spacing to every 12th zone.
    ' Or vice versa, by filling the picture with a large number of colors, and later
    ' covering some parts of this with one or two colors.
    '
    '
    ' -------------------------------------------------------------------------------
    ' NUMBER OF ZONES
    ' -------------------------------------------------------------------------------
    '
    ' The selected number of zones has a large effect upon the resulting picture.
    ' The menu allows up to 999 zones, but as an increasing number of zones reduces
    ' their width, at some point zones will simply disappear. However, even this may
    ' produce attractive results. The number of zones specified is for half the range,
    ' from zero to maximum, or from zero to minimum.
    '
    '
    ' -------------------------------------------------------------------------------
    ' SEPARATION
    ' -------------------------------------------------------------------------------
    '
    ' It is possible to specify that a region around zero is skipped.
    ' Doing this makes parts of the picture to become separated from each other.
    ' To make the specification independent of the number of zones, the separation
    ' parameter is expressed as a percentage of the range.
    '
    '
    ' -------------------------------------------------------------------------------
    ' UPDATE TIME
    ' -------------------------------------------------------------------------------
    '
    ' Coloring continues as long as the application is running.
    ' Between each modification of the image, a waiting time is observed to enable the
    ' user to view the result. The duration of this time may be specified in millisec.
    ' Values 0 to 9999 may be entered.
    '
    '
    ' -------------------------------------------------------------------------------
    ' OHTER FUNCTIONS
    ' -------------------------------------------------------------------------------
    '
    ' PAINT           Clicking to this caption causes painting to start or to be resumed.
    '
    ' SAVE TO BMP     Saves the current image to a BMP file.
    '                 Files will be placed in a subdirectory \BMP\, and receive an auto
    '                 generated file name with date and time.
    '
    ' VIEW MODEL      A simple model viewer is provided to check the model.
    '
    ' CLEAR           Explicitly clears the window
    '
    '
    ' -------------------------------------------------------------------------------
    ' MODEL FILE
    ' -------------------------------------------------------------------------------
    '
    ' Models are located in an external model file, which makes it possible to write
    ' own models. One single file may contain multiple model descriptions.
    ' The application expects the model file in the same directory as the executable.
    ' Writing models is quite straightforward, and uses at this moment three statements:
    '
    '     MODEL, name
    '
    '         Each model description must start with the keyword MODEL, followed with
    '         a name. Name must be one single word without spaces.
    '         Name may be of any length, but only the first 16 characters will be listed.
    '
    '     POINT, x, y, value
    '
    '         This statement specifies one single point.
    '
    '     LINE, x1, y1, value1, x2, y2, value2
    '
    '         This statement specifies an array of points between endpoints x1,y1
    '         and x2,y2. The respective values are linearly interpolated between
    '         value1 and value2. This statement also offers the possibility of
    '         redefing the values at the edges, which are normally set to zero.
    '         A line with zero length is not allowed.
    '
    '     COMMENT
    '
    '         Everything after a single quote, and up to the end of a line is
    '         considered as comment, and ignored in processing.
    '
    ' Note the obligatory komma after the keyword.
    ' Also note that if not otherwise specified, all points along the edges
    ' are default set to zero.
    '
    '
    ' -------------------------------------------------------------------------------
    ' COORDINATES AND VALUE RANGE
    ' -------------------------------------------------------------------------------
    '
    ' Coordinate ranges are internally fixed as follows:
    '
    '         x coordinate    0 to 120
    '         y coordinate    0 to  90
    '
    '         The value assigned to a point is not formally restricted.
    '         However the plotrange is fixed as -100 to 100, which limits the practical
    '         range of values to about -300 to 300.
    '
    ' -------------------------------------------------------------------------------
    ' START OF CODE
    ' -------------------------------------------------------------------------------
     
    #Compiler PBCC
    #Compile Exe
    #Dim All
     
    ' ---------------------------------------------------------------------------
        ' Program messages
     
        $ProgramName         = "  Laplacian Graphics"
        $ModelFile           = "LapGraph.txt"
        $SaveParms           = "LapGraph.bin"
        $Error               = "Error(s) in model"
        $Unrecognised        = "  What do yo mean ?        :  "
        $PointArgCountError  = "  3 parameters are needed  :  "
        $LineArgCountError   = "  6 parameters are needed  :  "
        $PointOutOfBounds    = "  Point offscreen          :  "
        $ZeroLengthLine      = "  Line has zero length     :  "
        $Continue            = "  Continue anyway ? (Y/N)  :  "
        $ProgramAborted      = "  Program will terminate"
        $ProgramContinues    = "  Program will continue with model error"
        $Saved               = "Saved to: "
        $Hint                = "Use in Graphic mode:   SPACE  to pause  program   -   ENTER  to show Menu"
        $Author              = " - ver 1.0 - Arie Verheul 2008 - Public Domain Software"
     
    ' ---------------------------------------------------------------------------
        ' Program equates
     
        %NumIntX             = 120
        %NumIntY             =  90
        %PlotRange           = 100
        %ModNameLength       =  16
     
        %ConsFClr            =  10   ' Console colors
        %ConsHiClr           =  15
        %ConsBClr            =   0
     
        %MaxNumZones         = 999   ' Maximum allowed parameter values
        %MaXWhiteContent     =  99
        %MaxSeparation       =  99
        %MaxSleepTime        = 9999
     
     
        %Menu1Col            = 2     ' Menu positions
        %Menu2Col            = 20
        %Menu3Col            = 38
        %CaptionLen          = 16
        %InputPos            = 28
     
        %ModNameRow          = 2
        %UniBrightnessRow    = 12
        %NumZonesRow         = 16
        %SeparationRow       = 18
        %WhiteContentRow     = 20
        %UpdateTimeRow       = 22
     
     
    ' ---------------------------------------------------------------------------
        ' ProgramStatus bit index
     
        %ModelSelected       =   1
        %ModelLoaded         =   2
        %ModelError          =  16
        %MenuHidden          =  20
        %ProgramPaused       =  29
        %ProgramInterrupted  =  30
        %ProgramAborted      =  31
     
    ' ---------------------------------------------------------------------------
    Type ContourParmset          ' Variable to store plot settings
     
        NumZones        As Word  ' Number of zones in pos. and neg. half of range
     
        DiceMode        As Word  ' Mode 1 = pseudo random 3 color
                                 ' Mode 2 = pseudo random 2 color (saturated)
                                 ' Mode 3 = R + G only
                                 ' Mode 4 = R + B only
                                 ' Mode 5 = B + G only
     
        UniBrightness   As Word  ' On/off switch for uniform uniform brightness
     
        WhiteContent    As Word  ' Specifies amount of white in pastel colors
     
        MapMode         As Word  ' Specifies relation of colors in pos. and neg. zones
                                 ' Mode 1 = Complementary
                                 ' Mode 2 = Rotate right
                                 ' Mode 3 = Rotate left
                                 ' Mode 4 = Swap R <> G
                                 ' Mode 5 = Swap R <> B
                                 ' Mode 6 = Swap B <> G
                                 ' Mode 7 = Independent
     
        Interlacing     As Word  ' Specifies interlacing
                                 ' Mode 1 = Every zone
                                 ' Mode 2 = Every 2nd zone
                                 ' Mode 3 = Every 3rd zone
                                 ' Mode 4 = Every 4th zone
                                 ' Mode 5 = Every 6th zone
                                 ' Mode 6 = Every 12th zone
     
        Separation      As Word  ' Specifies area around zero to skip
        SleepTime       As Word
        GraphicBGCol    As Long
    End Type
     
    ' ---------------------------------------------------------------------------
    Type CHOOSECOLORAPI          ' Variable for Windows color dialog box
     
        lStructSize     As Long
        hwndOwner       As Dword
        hInstance       As Dword
        rgbResult       As Long
        lpCustColors    As Long Ptr
        Flags           As Dword
        lCustData       As Long
        lpfnHook        As Dword
        lpTemplateName  As Asciiz Ptr
    End Type
     
    ' ---------------------------------------------------------------------------
    ' Sub and function declarations
     
    Declare Sub         DisplayMenu     (Action () As Byte)
    Declare Sub         MainMenu
    Declare Sub         HighlightSelection
    Declare Function    SelectModel     As String
    Declare Sub         LoadModel
    Declare Sub         FiniteDifference
    Declare Sub         MapArrayToWindow
    Declare Sub         ColorPlot
    Declare Sub         EstablishColors (PositiveShade As Long, NegativeShade As Long)
    Declare Sub         ColorDice       (RGB_() As Integer)
    Declare Sub         SetGraphicWindow
    Declare Sub         SetBGColor
    Declare Sub         ViewModel
    Declare Sub         SetConsole      (ConsType As Long)
    Declare Function    IntegerInput    (NumDigits As Long) As Long
    Declare Function    ExePath          As String
    Declare Sub         UpdatePParms    (ByVal Modus As Asciiz*2)
    Declare Sub         ProgramReset
    Declare Sub         ErrorHandler    (ErrorReport As String)
    Declare Sub         SaveToBitMap
    Declare Sub         TextBox         (Caption As String, VertPos As Long)
    Declare Sub         Process_Windows_Message( ByVal hWnd As Dword, ByVal wMsg As Dword,_
                                              ByVal wParam As Dword, ByVal lParam As Long)
     
    ' ---------------------------------------------------------------------------
    ' Windows API declarations
     
    Declare Function CallWindowProc Lib "USER32.DLL" Alias "CallWindowProcA" (_
                             ByVal lpPrevWndFunc As Dword,_
                             ByVal hWnd As Dword,_
                             ByVal uMsg As Dword,_
                             ByVal wParam As Dword,_
                             ByVal lParam As Long) As Long
     
    Declare Function ChooseColor Lib "COMDLG32.DLL" Alias "ChooseColorA"(_
                             lpcc As CHOOSECOLORAPI) As Long
     
    Declare Function DeleteMenu Lib "USER32.DLL" Alias "DeleteMenu"(_
                             ByVal hMenu As Dword,_
                             ByVal nPosition As Long,_
                             ByVal wFlags As Dword) As Long
     
    Declare Function GetModuleFileName Lib "KERNEL32.DLL" Alias "GetModuleFileNameA"(_
                             ByVal hModule As Dword,_
                                   lpFileName As Asciiz,_
                             ByVal nSize As Dword) As Dword
     
    Declare Function GetSystemMenu Lib "USER32.DLL" Alias "GetSystemMenu"(_
                             ByVal hWnd As Dword,_
                             ByVal bRevert As Long) As Long
     
    Declare Function GetWindow Lib "USER32.DLL" Alias "GetWindow" (_
                             ByVal hWnd As Dword,_
                             ByVal wCmd As Dword) As Long
     
    Declare Function IsWindow Lib "USER32.DLL" Alias "IsWindow" (ByVal hWnd As Dword) As Long
     
    Declare Function SetWindowLong Lib "USER32.DLL" Alias "SetWindowLongA" (_
                             ByVal hWnd As Dword,_
                             ByVal nIndex As Long,_
                             ByVal lNewLong As Long) As Long
     
    Declare Function ShowWindow Lib "USER32.DLL" Alias "ShowWindow"(_
                             ByVal hWnd As Dword,_
                             ByVal nCmdShow As Long) As Long
    ' ---------------------------------------------------------------------------
        ' Windows API equates
     
        %SC_MINIMIZE         = &HF020
        %SC_RESTORE          = &HF120
        %WM_DESTROY          = &H2
        %GW_CHILD            =  5
        %GWL_WNDPROC         = -4
        %WM_LBUTTONDOWN      = &H201
        %WM_CHAR             = &H102
        %WM_DESTROY          =  2
        %CC_RGBINIT          =  1
        %CC_FULLOPEN         =  2
     
    ' ---------------------------------------------------------------------------
     
    Function PBMain () As Long
     
        Local WinWidth, WinHeight As Long
     
        Dim PParms         As Global ContourParmset
        Dim hWnd           As Global Dword
        Dim OldProc        As Global Long
        Dim ProgramStatus  As Global Dword
        Dim ModelName      As Global String * %ModNameLength
     
        SetGraphicWindow
     
        Graphic Get Client To WinWidth, WinHeight
     
        Dim PlotArray   (%NumIntX, %NumIntY)                     As Global Single
        Dim Boundary    (Ceil(%NumIntX + 1)*(%NumIntY + 1) / 32) As Global Dword
        Dim ScreenArray (1 To WinWidth, 1 To WinHeight)          As Global Integer
     
        TextBox  $ProgramName + $Author, 50
        TextBox  $Hint, WinHeight - 90
     
        UpdatePParms "Load"
        MainMenu
     
    End Function
     
    ' ---------------------------------------------------------------------------
     
    Sub DisplayMenu (Action () As Byte)
     
        ' Prints menu captions
     
        Local N, MenuLength, Row, Col As Long
     
        SetConsole 1
     
        MenuLength = IIf(Bit(ProgramStatus, %ModelLoaded), DataCount, DataCount - 24)
     
        ' Display 'Paint' through 'Save to BMP' captions only after model has been loaded
     
        For N = 1 To MenuLength  Step 4            ' Print menu captions
     
            Row = Val(Read$(N))
            Col = Val(Read$(N + 1))
     
            Action(Col, Row) = Val(Read$(N + 2))   ' Action() stores indices of actions
                                                   ' associated with captions
     
            Col = Choose&(Val(Read$(N + 1)),%Menu1Col,%Menu2Col,%Menu3Col)
     
            If Read$(N + 3) <> "" Then
                Locate Row, Col
                Print Chr$(219,32) + Read$(N + 3);
            End If
        Next N
     
        For N = 1 To 8                                   ' Print separation lines
     
            Locate Choose&(N,3,5,13,15,17,19,21,23), 1
            Print String$(56,196)
        Next N
     
        Locate 11,2: Print String$(%CaptionLen + 1,196)  ' And one more separation
     
    Exit Sub
     
    ' ---------------------------------------------------------------------------
     
    ' Menu captions may be changed, provided that new captions do not exceed %CaptionLen.
    ' Button type captions may simply be deleted from the list, if desired.
     
    ' Row, MenuColumn, Action, Caption
     
    Data  2, 1, 1,  "Select Model"
    ' row stored in %ModNameRow
     
    Data  4, 1, 0,  "COLOR"
     
    Data  6, 1, 11, "Random 3 color"
    Data  7, 1, 12, "Saturated"
    Data  8, 1, 13, "Red  + Green"
    Data  9, 1, 14, "Red  + Blue"
    Data 10, 1, 15, "Blue + Green"
     
    Data 12, 1, 19, "Uni Brightness"
    ' row stored in %UniBrightnessRow
     
     
    Data  4, 2, 0,  "COMPOSITION"
     
    Data  6, 2, 21, "Complementary"
    Data  7, 2, 22, "Rotate right"
    Data  8, 2, 23, "Rotate left"
    Data  9, 2, 24, "Swap R <> G"
    Data 10, 2, 25, "Swap R <> B"
    Data 11, 2, 26, "Swap B <> G"
    Data 12, 2, 27, "Independent"
     
    Data  4, 3,  0, "SPACING"
     
    Data  6, 3, 31, "Every zone"
    Data  7, 3, 32, "Every  2nd zone"
    Data  8, 3, 33, "Every  3rd zone"
    Data  9, 3, 34, "Every  4th zone"
    Data 10, 3, 35, "Every  6th zone"
    Data 11, 3, 36, "Every 12th zone"
     
    ' The following four items stretch over two columns and are therefore registered in both
    ' When moving these items change both DATA statements and equates
     
    Data 16, 1, 41, "Number of zones"
    Data 16, 2, 41, ""
    ' row stored in %NumZonesRow
     
    Data 18, 1, 42, "Separation (%)"
    Data 18, 2, 42, ""
    ' row stored in %SeparationRow
     
    Data 20, 1, 43, "Pastel white content"
    Data 20, 2, 43, ""
    ' row stored %WhiteContentRow
     
    Data 22, 1, 44, "Update time (ms)"
    Data 22, 2, 44, ""
    ' row stored in %UpdateTimeRow
     
    ' The following six items are only to be displayed if model is loaded
    ' and must therefore remain at the end of the list
     
    Data 14, 3, 51, "Paint"
    Data 16, 3, 49, "Set BG Color"
    Data 18, 3, 53, "Clear Window"
    Data 20, 3,255, "Hide Menu"
    Data 22, 3, 52, "View model
    Data 24, 3, 54, "Save to BMP"
     
    End Sub
     
    ' ---------------------------------------------------------------------------
     
    Sub MainMenu
     
        ' Handles menu actions
     
        Local M, N, MenuAction As Byte
        Local KeyVal As String
        Dim   Action (1 To 3, 1 To 25) As Byte
     
        DisplayMenu Action()
     
        Do
            HighlightSelection
            Do
     
                MenuAction = 0
                Do
                    If IsFalse Bit(ProgramStatus,%MenuHidden) Then Console Set Focus
                    Sleep 100
                    KeyVal = InKey$
                    N = Len(KeyVal)
     
                Loop Until N = 4   ' Wait for mouseclick
     
                ' -----------------------------------------------------------------
                ' Determine MenuAction from MouseX and MouseY
     
                Select Case MouseX
     
                    Case %Menu1Col + 2 To %Menu2Col - 2 : N = 1   ' First column
                    Case %Menu2Col + 2 To %Menu3Col - 2 : N = 2   ' Second column
                    Case > %Menu3Col + 1                : N = 3   ' Third column
                End Select
     
                MenuAction = Action(N, MouseY)
            Loop Until MenuAction
     
            ' ------------------------------------------------------------------
            ' Perform desired action
     
            Select Case MenuAction
     
                Case 1                          ' Select model
                    ProgramReset
                    LoadModel
                    FiniteDifference
                    DisplayMenu Action()
     
                Case 11 To 15                   ' Set Dice mode
                    PParms.DiceMode = MenuAction - 10
     
                Case 19
                    Bit Toggle PParms.UniBrightness, 1
     
                Case 21 To 27                   ' Set Map mode
                    PParms.MapMode = MenuAction - 20
     
                Case 31 To 36                   ' Set Interlacing
                    PParms.InterLacing = MenuAction - 30
     
                Case 41                         ' Set Number of zones
                    Locate %NumZonesRow, %InputPos
                    PParms.NumZones = IntegerInput(3)
     
                Case 42                         ' Set separation
                    Locate %SeparationRow, %InputPos
                    PParms.Separation = IntegerInput(2)
     
                Case 43                         ' Set Pastel White component
                    Locate %WhiteContentRow, %InputPos
                    PParms.WhiteContent = IntegerInput(2)
     
                Case 44                         ' Set Update time
                    Locate %UpdateTimeRow, %InputPos
                    PParms.SleepTime = IntegerInput(4)
     
                Case 49 : SetBGColor            ' Set BG color
     
                Case 51                         ' Paint
                     Bit Reset ProgramStatus, %ProgramInterrupted
                     MapArrayToWindow
                     ColorPlot
     
                Case 52                         ' View model
                    ViewModel
                    Graphic Attach hWnd,0       ' Return to main window
     
                Case 53                         ' Clear window
                    Graphic Color 0, PParms.GraphicBGCol
                    Graphic Clear
     
                Case 54 : SaveToBitMap
     
                Case 255                         ' Dummy loop to keep menu hidden
                    Bit Set ProgramStatus, %MenuHidden
                    Graphic Set Focus
                    Do: Sleep 100: Loop Until IsFalse Bit(ProgramStatus, %MenuHidden)
     
            End Select
     
            UpdatePParms "Save"
     
        Loop Until Bit(ProgramStatus,%ProgramAborted)
     
    End Sub
     
    ' ---------------------------------------------------------------------------
     
    Sub HighlightSelection
     
        ' Highlights selections in main menu, and prints values of settings
     
        Local N, M, MenuCol As Long
     
        For N = 6 To 14                            ' Remove previous highlights
            Locate N, 1
            Color %ConsFClr, %ConsBClr,56
        Next N
     
        For N = 1 To 3                             ' Make new highlights
     
            MenuCol = Choose&(N,%Menu1Col,%Menu2Col,%Menu3Col) + 2
     
            M = Choose&(N,PParms.DiceMode, PParms.MapMode, PParms.Interlacing) + 5
     
            Locate M, MenuCol
            Color %ConsHiClr, %ConsBClr,%CaptionLen
        Next N
     
        If PParms.UniBrightness Then               ' Treat uniform brightnes as a separate case
            Locate %UniBrightnessRow, %Menu1Col + 2
            Color %ConsHiClr, %ConsBClr,%CaptionLen
        End If
     
        ' ----------------------------------------------------------------------
     
        ' Print current PParms values
     
        Color %ConsHiClr, %ConsBClr
     
        Locate %NumZonesRow,     %InputPos: Print Using$(" #### ";PParms.NumZones)
        Locate %SeparationRow,   %InputPos: Print Using$(" #### ";PParms.Separation)
        Locate %WhiteContentRow, %InputPos: Print Using$(" #### ";PParms.WhiteContent)
        Locate %UpdateTimeRow,   %InputPos: Print Using$(" #### ";PParms.SleepTime)
     
        ' If model has been selected then print model name
     
        Locate %ModNameRow, %Menu2Col
     
        If Bit(ProgramStatus, %ModelSelected) Then
            Print ModelName;
        Else
            Print Spc(%ModNameLength);
        End If
     
        Color %ConsFClr, %ConsBClr
     
    End Sub
     
    ' ---------------------------------------------------------------------------
     
    Function SelectModel As String
     
        ' Reads the model file and selects one model from it
     
        Local I, J, ModelCount, LineCount As Long
        Local A_String, B_String  As String
     
        ' ---------------------------------------------------------------------------
     
        Open ExePath + $ModelFile For Binary As #0  ' Load model file into string
            Get$ 0, Lof(0), A_String
        Close #0
     
        ' ---------------------------------------------------------------------------
        ' Organise model data
     
        LineCount = ParseCount (A_String, Chr$(13,10))
     
        Dim Model(LineCount) As String              ' Determine number of lines
     
        Parse A_String, Model(), Chr$(13,10)        ' Parse buffer into lines to array Model()
     
        For I = 0 To LineCount                      ' Remove comment
            Model(I) = Extract$(Model(I), "'")
        Next I
     
        A_String = Join$(Model(),Chr$(13,10))       ' Join the result back to A_String
     
        B_String = MCase$ (A_String)                ' Convert to mixed case
        A_String = Remove$(B_String, Chr$(32))      ' Remove spaces
        B_String = Remove$(A_String, Chr$(10,13))   ' Remove empty lines
        A_String = Remove$(B_String, Chr$(10))      ' Remove Line feeds
     
        ' Model data is now organised
     
        ' ---------------------------------------------------------------------------
     
        ' Determine number of models in model file
     
        ModelCount = Tally(A_String, "Model")
     
        SetConsole 2
        Console Name "Select Model"
        If ModelCount > 30 Then Console Set Virtual  ModelCount, %ModNameLength
     
        ' If list does not fit in window, then make window scrollable
     
        ' ---------------------------------------------------------------------------
     
        ReDim Model(ModelCount) As String
     
        Parse A_String, Model(), "Model,"
     
        ' This results in an array of strings, each containing one model description
     
        For J = 1 To ModelCount    ' Extract and print model names
            Locate J,1
            Print Chr$ (254,32) + Extract$(Model(J),Chr$(13))
        Next J
     
        Console Set View 1, 1      ' Set to top if list higher than window
     
        Do
             Console Set Focus
             Sleep 100
        Loop Until Len(InKey$) = 4  And MouseY <= ModelCount    ' Wait for mouse click
     
        Locate MouseY, 2
        Color %ConsHiClr, %ConsBClr, %ModNameLength             ' Highligth selection
     
        Function = Model(MouseY)                                ' Extract selected model
     
        ' Selected model has been extracted
     
    End Function
     
    ' ---------------------------------------------------------------------------
     
    Sub LoadModel
     
        Local I, J, M, N, X1, Y1, X2, Y2 As Long
        Local A, B, V1, V2 As Single
        Local ModelBuffer, ErrorReport As String
     
        ' ---------------------------------------------------------------------------
     
        ' Boundary points must be left untouched by Finite difference algorithm
        ' Therefore all Boundary points are marked in bitarray Boundary(0)
     
        For J = 0 To %NumIntX               ' Mark boundary points along the edges
     
            For I = 1 To 4
     
                M = Choose&(I, 0, J, %NumIntY, J)
                N = Choose&(I, J, 0, J, %NumIntX)
     
                If M > %NumIntY Then Iterate For
     
                Bit Set Boundary(0), (120 * M + N)
            Next I
        Next J
     
        ' ---------------------------------------------------------------------------
     
        ModelBuffer = SelectModel                  ' Call Selectmodel to get a model
     
        I = ParseCount (ModelBuffer, $Cr)          ' Parse model into lines
     
        Decr I                                     ' Use zero based array
     
        Dim Model(I) As String                     ' Dim array to store parsed elements
     
        Parse ModelBuffer, Model(), $Cr
     
        ModelName = Model(0)
     
        Bit Set ProgramStatus, %ModelSelected
     
        ' ---------------------------------------------------------------------------
     
        ' This section parses statements, checks them and enters values
        ' Any error reports are written to string ErrorReport
     
        For J = 1 To I                             ' Extract statements
     
            If Model(J) = "" Then Iterate For      ' Last element may be empty
     
            Select Case Parse$(Model(J),1)         ' ... and process parameters
     
                ' ---------------------------------------------------------------
     
                Case "Point"
     
                    If ParseCount(Model(J)) <> 4 Then   ' Report incorrect statement
     
                        Bit Set ProgramStatus, %ModelError
                        ErrorReport = ErrorReport + $PointArgCountError + Model(J) +$CrLf
                        Iterate For
                    End If
     
                    N  = Val(Parse$(Model(J),2))
     
                    M  = Val(Parse$(Model(J),3))
     
                    V1 = Val(Parse$(Model(J),4))
     
                    If N >= 0 And N <= %NumIntX And _          ' Check for off screen
                       M >= 0 And M <= %NumIntY Then
     
                        PlotArray(N, M) = V1                   ' Assign value
                        Bit Set Boundary(0), (120 * M + N)     ' Mark boundary point
                    Else
                        Bit Set ProgramStatus, %ModelError
                        ErrorReport = ErrorReport + $PointOutOfBounds + Model(J) + $CrLf
                    End If
     
                ' ---------------------------------------------------------------
     
                Case "Line"
     
                    If ParseCount(Model(J)) <> 7 Then   ' Report incorrect statement
     
                        Bit Set ProgramStatus, %ModelError
                        ErrorReport = ErrorReport + $LineArgCountError + Model(J) + $CrLf
                        Iterate For
                    End If
     
                    X1 = Val(Parse$(Model(J),2))   ' Read first endpoint
     
                    Y1 = Val(Parse$(Model(J),3))
     
                    V1 = Val(Parse$(Model(J),4))
     
                    X2 = Val(Parse$(Model(J),5))   ' Read second endpoint
     
                    Y2 = Val(Parse$(Model(J),6))
     
                    V2 = Val(Parse$(Model(J),7))
     
                    If X1 = X2 And Y1 = Y2 Then    ' Zero length
     
                        Bit Set ProgramStatus, %ModelError
                        ErrorReport = ErrorReport + $ZeroLengthLine + Model(J)  + $CrLf
                        Iterate For
                    End If
     
                    If Abs(X2 - X1) > Abs(Y2 - Y1) Then ' Line is prevailing horizontal
     
                        A = (Y2 - Y1) / (X2 - X1)       ' Calculate slope of line
                        B = (V2 - V1) / (X2 - X1)       ' with respect to hor. axis
     
                        For N = X1 To X2 Step Sgn (X2 - X1)
     
                            M = Y1 + A * (N - X1)       ' Calculate vert. position of point
     
                            If N < 0 Or N > %NumIntX Or _
                               M < 0 Or M > %NumIntY Then Iterate For
     
                            PlotArray (N,M) = V1 + B * (N - X1) ' Calculate value for point
                            Bit Set Boundary(0), (120 * M + N)  ' Mark boundary point
                        Next N
     
                    Else                                ' Line is prevailing vertical
                        A = (X2 - X1) / (Y2 - Y1)       ' Calculate slope of line
                        B = (V2 - V1) / (Y2 - Y1)       ' with respect to vert. axis
     
                        For M = Y1 To Y2 Step Sgn (Y2 - Y1)
     
                            N = X1 + A * (M - Y1)       ' Calculate hor. position of point
     
                            If N < 0 Or N > %NumIntX Or _
                               M < 0 Or M > %NumIntY Then Iterate For
     
                            PlotArray (N,M) = V1 + B * (M - Y1) ' Calculate value for point
                            Bit Set Boundary(0), (120 * M + N)  ' Mark boundary point
                        Next M
                    End If
     
                ' ---------------------------------------------------------------
     
                Case Else                               ' Unrecognised statement
                    Bit Set ProgramStatus, %ModelError
                    ErrorReport = ErrorReport + $Unrecognised + Model(J) + $CrLf
                End Select
        Next J
     
        If Bit(ProgramStatus, %ModelError) Then ErrorHandler ErrorReport
     
    End Sub
     
    ' ---------------------------------------------------------------------------
     
    Sub FiniteDifference ()
     
    ' This is the Finite Difference algortithm
     
        Local K, N, M, I As Long
     
        For I = 1 To 2000                   ' Iterations
            For M = 1 To %NumIntY - 1       ' Vert. direction
                For N = 1 To %NumIntX - 1   ' Hor. direction
     
                    K = 120 * M + N
                    If Bit (Boundary(0),K) Then Iterate For
     
                    PlotArray(N,M) = (PlotArray(N-1,M) + PlotArray(N+1,M)_
                                     + PlotArray(N,M-1) + PlotArray(N,M+1)) / 4
                Next N
            Next M
        Next I
     
        Bit Set ProgramStatus, %ModelLoaded
    End Sub
     
    ' ---------------------------------------------------------------------------
     
    Sub MapArrayToWindow
     
        ' This sub calculates linearly interpolated values from the PlotArray() grid
        ' for each pixel in ScreenArray()
     
        ' Note: in the following the rectangular area enclosed by
        ' four neighbouring gridpoints is designated as an element
     
        Local WinWidth, WinHeight As Long
        Local Xmax, Ymax As Long
        Local ColorIndex, ColorScaleUBound, ColorScaleLBound As Long
        Local I, ElementRow, Pix, PixRow, ArrayRow, CurrentRow As Long
        Local X, PixRowPos, VertIntFactor, CalibrationFactor As Single
     
        Xmax                =  %NumIntX
        Ymax                =  %NumIntY
     
        WinWidth            =  UBound(ScreenArray(),1)
        WinHeight           =  UBound(ScreenArray(),2)
     
        CalibrationFactor   =  PParms.NumZones / %PlotRange
        ColorScaleUBound    =  PParms.NumZones
        ColorScaleLBound    = -PParms.NumZones
     
        ' ---------------------------------------------------------------------------
     
        Dim TopRow(Xmax)            As Single    ' Top nodes of current element row
        Dim BotRow(Xmax)            As Single   ' Bottom nodes of current element row
        Dim RowDiff(Xmax)           As Single   ' Differential (TopRow() - BotRow)
        Dim InterpRow(Xmax)         As Single   ' Interpolated values for position of pixel row
        Dim ElDiff(Xmax - 1)        As Single   ' Hor. differential in InterpRow()
        Dim HorIntNumber (WinWidth) As Long     ' Element to use for interpolation for specific pixel
        Dim HorIntFactor (WinWidth) As Single   ' Interpolation factor for specific pixel
     
        ' ---------------------------------------------------------------------------
        ' Make tables for pixel locations and interpolation factors in element grid coordinates
        ' in horizontal direction; these tables are valid for each row of pixels.
     
        For Pix = 1 To WinWidth             ' For each pixel in horizontal row
     
            X = Pix * Xmax / WinWidth       ' > Pixel position in element grid coordinates
            HorIntNumber (Pix) = Int  (X)   ' > Element where pixel is located
            HorIntFactor (Pix) = Frac (X)   ' > Interpolation factor within element
        Next  Pix
     
        ' ---------------------------------------------------------------------------
        ' Do the actual interpolation, working row by row
     
        CurrentRow = -1                   ' Pointer to keep track of current element row
     
        ArrayRow = WinHeight              ' Position in ScreenArray() :
                                          ' As PlotArray() has origin at left-bottom,
                                          ' ScreenArray() has origin at left top,
                                          ' so while PixRow goes up, ArrayRow goes down
     
        For PixRow = 0 To WinHeight - 1               ' Work row by row
     
            ' Note : PixRowPos may under no circumstance be outside the domain.
     
           PixRowPos = Ymax*(PixRow + .5) / WinHeight ' Vertical position of pixel row
                                                      ' in element grid coordinates
     
            ElementRow    = Int  (PixRowPos)          ' Element row to use for interpolation
            VertIntFactor = Frac (PixRowPos)          ' Interpolation factor
     
            If ElementRow <> CurrentRow Then          ' If interpolation has reached next
                                                      ' element row then data must be refreshed
     
                ' Full row of data is extracted from PlotArray() by placing 1D array on top
                ' Using MAT these data are manipulated row by row
     
                ReDim TopRow(Xmax) As Single At VarPtr (PlotArray(0, ElementRow + 1))
                ReDim BotRow(Xmax) As Single At VarPtr (PlotArray(0, ElementRow))
     
                Mat   RowDiff() = TopRow() - BotRow()    ' Vertical differentials
     
                CurrentRow = ElementRow
            End If
     
            Mat    InterpRow () = (VertIntFactor) * RowDiff()
            Mat    InterpRow () = BotRow() + InterpRow()
     
            ' InterpRow() now contains an interpolated row of data from PlotArray()
            ' at PixRowPos, the position of the row of pixels that is treated currently.
     
        ' ---------------------------------------------------------------------------
            ' Next within this row the differentials are calculated, and stored in ElDiff()
     
            For I = 0 To Xmax - 1           ' Horizontal differential in InterpRow()
     
                ElDiff(I) = InterpRow(I + 1) - InterpRow(I)
            Next I
     
        ' ---------------------------------------------------------------------------
            ' From InterpRow() and ElDiff() the values for each pixel are calculated
     
            For Pix = 1 To WinWidth      ' Work along a row of pixels
     
                I = HorIntNumber(Pix)    ' Element where pixel is located
     
                ColorIndex = (CalibrationFactor * (InterpRow(I) + ElDiff(I) * HorIntFactor(Pix)))
     
                ColorIndex = Min(ColorIndex, ColorScaleUBound)  ' overflow check
                ColorIndex = Max(ColorIndex, ColorScaleLBound)
     
                ScreenArray(Pix, ArrayRow) = ColorIndex
            Next Pix
     
            Decr ArrayRow
        Next PixRow
     
    End Sub
     
    ' ---------------------------------------------------------------------------
     
    Sub ColorPlot ()
     
        ' This sub translates values associated with pixels into shades
     
        Local I, N As Long
        Local ColorIndex, ColorScaleUBound, ColorScaleLBound As Long
        Local Separation, InterLacing, PositiveShade, NegativeShade As Long
        Local WindowImage As String
     
        Dim   PixelPtr As Long Pointer
        Dim   MapPtr   As Integer Pointer
     
        ColorScaleUBound =  PParms.NumZones
        ColorScaleLBound = -PParms.NumZones
     
        Separation       = PParms.Separation * ColorScaleUBound / 100
        InterLacing      = Choose&(PParms.Interlacing,5,2,3,4,6,0)
     
        SetGraphicWindow
     
        ' ---------------------------------------------------------------------------
        ' Note: GRAPHIC GET BITS / GRAPHIC SET BITS is used here
        ' because it is much faster than GRAPHIC SET PIXEL
     
         Graphic Get Bits To WindowImage       ' Get copy of video memory
     
        ' ---------------------------------------------------------------------------
     
        N = Rnd(-Timer)                   ' Random seed
     
        I = 0
     
        Do
            I = I Mod 12                  ' I walks through values 0 to 11, in a way
                                          ' determined by Interlacing parameter
     
       '    For ColorIndex = Separation + I To ColorScaleUBound Step 12     ' Work upwards
                                                                            ' or
            For ColorIndex = ColorScaleUBound - I To Separation Step -12    ' Work downwards
     
                While Bit(ProgramStatus, %ProgramPaused)    ' When paused program rests here
                    Sleep 100
                Wend
     
                EstablishColors PositiveShade, NegativeShade
     
                PixelPtr = StrPtr(WindowImage) + 8          ' First two Long Int. contain size
     
                MapPtr   = VarPtr (ScreenArray(1,1))
     
                ' Work zone by zone, this is programmatically inefficient,
                ' but looks much better than updating a full screen at the time
     
                For N = 1 To (Len(WindowImage) - 8) / 4     ' = WinWidth*WinHeight
     
                    ' Check for each element in ScreenArray() if it is in one of the
                    ' two current zones, and write corresponding color to WindowImage
     
                    If @MapPtr =  Colorindex Then @PixelPtr = PositiveShade                     '
                    If @MapPtr = -Colorindex Then @PixelPtr = NegativeShade
     
                    Incr PixelPtr
                    Incr MapPtr
                Next N
     
                Graphic Set Bits WindowImage         ' Put modified WindowImage back
     
                For N = 1 To PParms.SleepTime / 100  ' Sleep, but wake up every now
                                                     ' and then to check for key press
                    Sleep 100
                    If Bit(ProgramStatus, %ProgramInterrupted) Then Exit For
                Next N
     
            Next ColorIndex
     
            I = I + Interlacing
     
        Loop Until Bit(ProgramStatus, %ProgramInterrupted)
     
    End Sub
     
    ' ---------------------------------------------------------------------------------
     
    Sub EstablishColors (PositiveShade As Long, NegativeShade As Long)
     
        ' Determines values for positive and negative colors according to settings
     
        Dim RGB_(2) As Integer
     
        ColorDice RGB_()
     
        PositiveShade = RGB(RGB_(2),RGB_(1),RGB_(0))
     
        Select Case PParms.MapMode  ' Determines how positive and negative colors are related
     
            Case 1 : NegativeShade = RGB(255-RGB_(2),255-RGB_(1),255-RGB_(0))   ' Complementary
     
            Case 2 : NegativeShade = RGB(RGB_(1),RGB_(0),RGB_(2))       ' Rotate right
     
            Case 3 : NegativeShade = RGB(RGB_(0),RGB_(2),RGB_(1))       ' Rotate right
     
            Case 4 : NegativeShade = RGB(RGB_(2),RGB_(0),RGB_(1))       ' Swap Red and Green
     
            Case 5 : NegativeShade = RGB(RGB_(0),RGB_(1),RGB_(2))       ' Swap Red and Blue
     
            Case 6 : NegativeShade = RGB(RGB_(1),RGB_(2),RGB_(0))       ' Swap Blue and Green
     
            Case 7 : ColorDice RGB_(): NegativeShade = RGB(RGB_(2),RGB_(1),RGB_(0))
     
        End Select
    End Sub
     
    ' ---------------------------------------------------------------------------------
     
    Sub ColorDice (RGB_() As Integer)
     
        Local K As Long
        Local Brightness As Single
     
        ' Mode 1 = pseudo random 3 color
        ' Mode 2 = pseudo random 2 color (saturated)
        ' Mode 3 = R + G only
        ' Mode 4 = R + B only
        ' Mode 5 = B + G only
     
        For K = 0 To 2
            RGB_(K) = Rnd(PParms.WhiteContent,255)
        Next K
     
        If PParms.DiceMode > 1 Then            ' Eliminate one of the components
     
            K = Choose&(PParms.DiceMode,0,Rnd(0,2),2,1,0)
     
            RGB_(K) = PParms.WhiteContent
        End If
     
        If PParms.UniBrightness Then           ' Adjust brightness to 255, if selected
     
            Brightness = Sqr(RGB_(0)^2 + RGB_(1)^2 + RGB_(2)^2)
     
            Brightness = 255 / Brightness
     
            Mat RGB_() = (Brightness) * RGB_()
        End If
     
    End Sub
     
    ' ---------------------------------------------------------------------------------
     
    Sub SetGraphicWindow
     
        Local ClientX, ClientY, WinWidth, WinHeight As Long
        Local hStatic As Dword
     
        If IsFalse IsWindow(hWnd) Then        ' If window does not already exist
     
            Desktop Get Client To WinWidth, WinHeight
            Desktop Get Loc    To ClientX,  ClientY
     
            WinWidth  = WinWidth  - 2         ' Allow for border line
            WinHeight = WinHeight - 2
     
            Graphic Window "", ClientX, ClientY, WinWidth, WinHeight To hWnd
     
            Graphic Attach hWnd, 0
            Graphic Color  -1, PParms.GraphicBGCol
            Graphic Clear
     
            ' Subclass window to capture keyboard and mouse input
     
            hStatic = GetWindow(hWnd, %GW_CHILD)
     
            OldProc = SetWindowLong(hStatic, %GWL_WNDPROC, CodePtr(Process_Windows_Message))
        End If
     
        Graphic Set Focus
     
    End Sub
     
    ' -------------------------------------------------------------------------------
     
    Sub SetBGColor
     
        Dim   CustomColors(15)       As Static Long
        Dim   PixelPtr               As Long Pointer
        Local lpcc                   As ChooseColorAPI
        Local OldColor, NewColor, N  As Long
        Local WindowImage            As String
     
        ' Set ChooseColorAPI variable
     
        lpcc.hwndOwner    = hWnd
        lpcc.lpCustColors = VarPtr(CustomColors(0))
        lpcc.lStructSize  = SizeOf (lpcc)
        lpcc.flags        = %CC_RGBINIT Or %CC_FULLOPEN
        lpcc.rgbResult    = PParms.GraphicBGCol        ' Initialise ChooseColor
     
        Graphic Set Focus
     
        If IsFalse ChooseColor (lpcc) Then Exit Sub    ' ChooseColor aborted
     
        OldColor            = Bgr(PParms.GraphicBGCol)
        NewColor            = Bgr(lpcc.rgbResult)      ' RGB format produces BGR data
     
        PParms.GraphicBGCol = lpcc.rgbResult           ' Store result
     
        Graphic Get Bits To WindowImage                ' Get copy of video memory
     
        PixelPtr = StrPtr(WindowImage) + 8             ' First two Long Int. contain size
     
        For N = 1 To (Len(WindowImage) - 8) / 4
     
            If @PixelPtr = OldColor Then @PixelPtr = NewColor
            Incr PixelPtr
        Next N
     
        Graphic Set Bits WindowImage                   ' Put updated window map back
     
    End Sub
     
    ' ---------------------------------------------------------------------------
     
    Sub  ViewModel
     
    Local M, N, ColorToUse As Long
    Local hViewer As Dword
     
        Desktop Get Client To N, M
     
        N = (N - 800)/2     ' Center window on screen
        M = (M - 630)/2
     
        Graphic Window "Model Viewer : " + ModelName,N,M,800,600 To hViewer
        DeleteMenu GetSystemMenu(hViewer, 0), %SC_MINIMIZE, 0   ' Turn minimize button off
     
        Graphic Attach hViewer,0, ReDraw
        Graphic Scale (-1, %NumIntY + 1)-(%NumIntX + 1, -1)
        Graphic Color -1, %Black
        Graphic Clear
     
        For N = 0 To %NumIntX                               ' Draw grid
     
            ColorToUse = IIf(N Mod 10, &H003200, &H004800)  ' Highlight every 10th grid line
     
            Graphic Line (N,0)-(N,%NumIntY), ColorToUse
     
            If N <= %NumIntY Then Graphic Line (0,N)-(%NumIntX,N), ColorToUse
        Next N
     
        For M = 0 To %NumIntY                               ' Plot boundary points
            For N = 0 To %NumIntX
     
                If Bit (Boundary(0), (120 * M + N)) Then
     
                    ColorToUse = Choose&(2 + Sgn(PlotArray(N,M)), &HFF4000, &HA0A0A0, &H0040FF)
                    Graphic Ellipse (N - .4, M + .5)-(N + .6, M - .6), ColorToUse, ColorToUse
                End If
            Next N
        Next M
     
        Graphic ReDraw
     
        While IsWindow(hViewer)     ' Wait until window is closed
            Graphic Set Focus
            Sleep 100
        Wend
     
    End Sub
     
    ' ---------------------------------------------------------------------------------
     
    Sub SetConsole(ConsType As Long)
     
        Local Rows, Cols, Hcon, Wcon, WinWidth, WinHeight As Long
        Local FColor, Bcolor As Byte
     
        Desktop Get Client To WinWidth, WinHeight
     
        Rows = Choose&(ConsType,25,30,25)
        Cols = Choose&(ConsType,56,%ModNameLength + 3,80)
     
        Console Set Screen Rows, Cols
        Console Get Size To Hcon, Wcon                          ' Console size in pixels
        Console Name $ProgramName
        ShowWindow ConsHndl, 3
        DeleteMenu GetSystemMenu(ConsHndl, 0), %SC_RESTORE, 0   ' Turn icons off
        DeleteMenu GetSystemMenu(ConsHndl, 0), %SC_MINIMIZE, 0
        Console Set Loc (WinWidth - Hcon)/2, (WinHeight - Wcon)/2
        Color %ConsFClr, %ConsBClr
        Cursor Off
        Mouse On
        Mouse 1
     
    End Sub
     
    ' ---------------------------------------------------------------------------
     
    Function IntegerInput (NumDigits As Long) As Long
     
        ' This function provides a controlled input for an integer with max. NumDigits
     
        Local KeyVal, AcceptedInput As String
        Local I, StartPos, ResultValue As Long
     
        StartPos = CursorX
     
        GoSub ReadValueFromScreen                         ' Save current value
     
        Color %ConsBClr, %ConsHiClr, 6                    ' Make input field
        Print String$(6,32);
        Locate ,StartPos + 1
     
     
        I = 1
                               ' Beyond NumDigits only Bsp, Enter and Esc are allowed
        Do
            AcceptedInput = IIf$(I > NumDigits, Chr$(8,13,27),Chr$(8,13,27,48 To 57))
     
            Do
                KeyVal = WaitKey$
                If Len(KeyVal) = 4 Then Keyval = Chr$(13) ' Leftmouse = Chr$(13)
            Loop Until InStr (AcceptedInput, KeyVal)
     
            Select Case Asc(KeyVal)
     
                Case 8      ' Backspace
     
                    If I > 1 Then
                        Decr I
                        Locate ,CursorX - 1: Print Chr$(32);
                        Locate ,CursorX - 1
                    End If
     
                Case 13
                    GoSub ReadValueFromScreen
                    Exit Loop
     
                Case 27
                    Exit Loop
     
                Case Else
                    Print KeyVal;
                    Incr I
            End Select
        Loop
     
    Function = ResultValue
     
    Exit Function
     
    '---------------------------------------------------------------
     
    ReadValueFromScreen:
     
        KeyVal = ""
     
        For I = 0 To 5
            KeyVal = KeyVal + Chr$(Screen (CursorY, StartPos + I))
        Next I
     
        ResultValue = Val(KeyVal)
     
    Return
     
    End Function
     
    ' ---------------------------------------------------------------------------
     
    Function ExePath As String
     
        'Function returns path to executable, including last backslash
     
        Local PathName As Asciiz*128
        Local I As Long
     
        GetModuleFileName 0, PathName, 127
     
        I = InStr(-1,PathName,"\")
     
        Function = Left$(PathName,I)
     
    End Function
     
    ' ---------------------------------------------------------------------------
     
    Sub UpdatePParms (ByVal Modus As Asciiz*2)
     
        Select Case Modus
     
            Case "L"     ' Load values from file, or defaults instead
     
                Open ExePath + $SaveParms For Binary As #1
     
                    If Lof(1) < 20 Then                 ' No valid file present
     
                        PParms.DiceMode      =   1      ' Default Values
                        PParms.MapMode       =   2
                        PParms.NumZones      =  36
                        PParms.InterLacing   =   1
                        PParms.Separation    =  10
                        PParms.WhiteContent  =  20
                        PParms.SleepTime     = 500
     
                    Else
                        Seek 1,1
                        Get  1,,PParms
                    End If
                Close 1
                                                        ' Check values
     
                         PParms.NumZones     = Min&(PParms.NumZones,     %MaxNumZones)
                         PParms.WhiteContent = Min&(PParms.WhiteContent, %MaXWhiteContent)
                         PParms.Separation   = Min&(PParms.Separation,   %MaxSeparation)
                         PParms.SleepTime    = Min&(PParms.SleepTime,    %MaxSleepTime)
     
            Case "S"                                    ' Save values to file
     
                Open ExePath + $SaveParms For Binary As #1
                    Seek 1,1
                    Put  1,,PParms
                Close 1
     
            End Select
    End Sub
     
    ' ---------------------------------------------------------------------------
     
    Sub ProgramReset
     
        ProgramStatus   = 0
        ModelName       = ""
        Mat Boundary()  = Zer
        ReDim PlotArray (%NumIntX, %NumIntY)  As Global Single
        Graphic Color 0, PParms.GraphicBGCol
        Graphic Clear
     
    End Sub
     
    ' -------------------------------------------------------------------------------
     
    Sub ErrorHandler (ErrorReport As String)
     
    Local KeyVal As String
     
        SetConsole 3
     
        Locate 2,3
        Print $Error
        Locate 4,3
        Print String$(76,196)
        StdOut ErrorReport
        Print
        Print $Continue;
     
        Do
            Console Set Focus               ' To prevent console from disappearing
            KeyVal = UCase$(InKey$)
            Sleep 100
        Loop Until Len(KeyVal) > 0 And InStr("JYN", KeyVal)
     
        Print:Print
     
        Select Case KeyVal
     
            Case "Y", "J"
                Print $ProgramContinues
     
            Case "N"
                Print $ProgramAborted
                Bit Set ProgramStatus, %ProgramInterrupted
        End Select
     
        Sleep 2000
     
    End Sub
     
    ' ---------------------------------------------------------------------------
     
    Sub SaveToBitMap
     
        Local FileName, SavePath As String
     
        SavePath = ExePath + "BMP"
     
        If Dir$(SavePath, 16) = "" Then MkDir SavePath
     
        ' Make filename with date and time
     
        FileName = "Laplace_" + Left$(Date$,5) + "_" + Left$(Time$,5) + ".bmp"
     
        Replace ":" With "h" In FileName             ' Colon is not allowed in file names
     
        Graphic Save SavePath + "\" + FileName
     
        Locate 24,2
        Color %ConsFClr
        Print $Saved;
        Color %ConsHiClr
        Print FileName;
     
    End Sub
     
    ' -------------------------------------------------------------------------------
     
    Sub TextBox (Caption As String, VertPos As Long)
     
        ' Prints a text centered in a graphic window
        ' Top of box is located at VerPos, top of text 10 pix below
     
        Local WinWidth, TextLength, TextHeight, StartPoint As Single
     
        Graphic Font "Verdana", 10,1
        Graphic Color RGB(252,253,254), RGB(2,3,4)
        Graphic Width 3
     
        Graphic Get Client To WinWidth, TextHeight
        Graphic Text Size Caption To TextLength, TextHeight
        StartPoint = (WinWidth - TextLength) / 2
     
        Graphic Box (StartPoint - 20, VertPos) - _
                    (StartPoint + TextLength + 20, VertPos + TextHeight + 20), 20, RGB(1,191,2), RGB(2,3,4)
     
        Graphic Set Pos (StartPoint, VertPos + 10)
        Graphic Print Caption
     
    End Sub
     
    ' -------------------------------------------------------------------------------
     
    Sub Process_Windows_Message( ByVal hWnd As Dword, ByVal wMsg As Dword,_
                                 ByVal wParam As Dword, ByVal lParam As Long)
     
        Graphic Attach hWnd,0
     
        Select Case wMsg
     
            Case %WM_DESTROY
                Bit Reset ProgramStatus,%ProgramPaused
                Bit Set   ProgramStatus,%ProgramInterrupted
                Bit Set   ProgramStatus,%ProgramAborted
     
            Case %WM_LBUTTONDOWN
     
                Bit Set ProgramStatus, %ProgramInterrupted
                Bit Reset ProgramStatus, %ProgramPaused
                Bit Reset ProgramStatus, %MenuHidden
                ShowWindow ConsHndl,3
     
            Case %WM_CHAR
     
                Select Case wparam
     
                   Case 13
                       Bit Set   ProgramStatus, %ProgramInterrupted
                       Bit Reset ProgramStatus, %ProgramPaused
                       Bit Reset ProgramStatus, %MenuHidden
                       ShowWindow ConsHndl,3
     
                   Case 32
     
                       If IsFalse Bit(ProgramStatus, %MenuHidden) Then
                            Bit Toggle ProgramStatus, %ProgramPaused
                       End If
     
                End Select
     
            End Select
     
        CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)
     
    End Sub
     
    ' -------------------------------------------------------------------------------
    ' END OF CODE 
    ' -------------------------------------------------------------------------------


    The following contains 10 example models.
    Save it to a text file named LapGraph.txt and place it in the same directory as the executable.




    Code:
    ' Arie Verheul, november 2008
     
    Model, Flower
     
    'Note: paint with separation set to zero
     
    Point, 60, 45, 100                      ' Point at center
     
    Line, 60, 38, -100, 67, 45, -100        ' Inner rhombus
    Line, 67, 45, -100, 60, 52, -100
    Line, 60, 52, -100, 53, 45, -100
    Line, 53, 45, -100, 60, 38, -100
     
    Line, 45, 30,  100, 75, 30,  100        ' Square
    Line, 45, 60,  100, 75, 60,  100
    Line, 45, 30,  100, 45, 60,  100
    Line, 75, 30,  100, 75, 60,  100
     
    Line, 45, 30,  100, 30, 15,    0        ' Four diagonal outward lines
    Line, 75, 30,  100, 90, 15,    0
    Line, 45, 60,  100, 30, 75,    0
    Line, 75, 60,  100, 90, 75,    0
     
    Line,  0, 45,    0, 40, 45, -100        ' Four lines inward from edges
    Line,120, 45,    0, 80, 45, -100
    Line, 60,  0,    0, 60, 25, -100
    Line, 60, 90,    0, 60, 65, -100
     
    Model,Pattern
     
    Point,  30, 22,  250                    ' Left bottom
    Point,  90, 22, -275                    ' Right bottom
    Point,  30, 68, -275                    ' Left top
    Point,  90, 68,  250                    ' Right top
    Point,  60, 45,  225                    ' Center
     
    Model,Fish
     
    Line,  120,  18,   0, 120,  90,  80     ' Right side
    Line,    0,  90, -60,   0,  18,   0     ' Left side
    Line,   48,  90,   0,   0,  90, -60     ' Left top
    Line,  120,  90,  80,  80,  90,   0     ' Right top
     
    Line,  0,   0,   0, 48,  0,  70         ' Left bottom
    Line, 48,   0, -70, 96,  0,  0          ' Right bottom
     
    Point, 36, 27, -200                     ' Left fish's eye
    Point, 60, 27,  200                     ' Right fish's eye
     
    Model,Sheherazade
     
    Line,  60, 40,  300, 60, 10, -300       ' Vertical line across center
     
    Point, 60, 75, -200                     ' Tree points at the center
    Point, 60, 60,  200
    Point, 60, 45, -400
     
    Point, 30, 65, -100                     ' Point left top
    Point, 90, 65, -100                     ' Point right top
     
    Point, 18, 20, -100                     ' Point left bottom
    Point, 102,20, -100                     ' Point right bottom
     
    Model,Ladies
     
    Line, 30,0, 100, 30, 70, 100            ' Left head
    Line, 70,0,-100, 70, 80,-100            ' Right head
     
    Line,30,20,-100,70,20,100               ' Scarfs
    Line,30,20,-100,20,20,-80
    Line,70,20,100,80,20,80
     
    Line,0,0,0,30,0,100                     ' Bottom left
    Line,30,0,100,70,0,-100                 ' Bottom between bodies
     
    Line,70,0,-100,120,0,-50                ' Bottom right
    Line,120,0,-50,120,120,0                ' Right edge
     
    Model,Bello
     
    Point, 40, 45,  300
    Point, 60, 35, -300
    Point, 80, 45,  300
     
    Model,Meeting
     
    Line,   0,  0,  100, 120,  0, - 100     ' Bottom
    Line, 120,  0, -100, 120, 90,   100     ' Right side
    Line, 120, 90,  100,   0, 90,  -100     ' Top
    Line,   0, 90, -100,   0,  0,   100     ' Left side
     
    Point, 36,  68, -280                    ' Four eyes
    Point, 60,  40, -280
    Point, 36,  40,  280
    Point, 60,  68,  280
     
    Model,Cactus
     
    Point, 48, 45, -300
    Point, 60, 45,  300
    Point, 36, 45, -300
     
    Line,  36, 45,   100,  0, 0, 100        ' Two lines from left bottom corner
    Line,  84, 45,  -100, 20, 0,-100
     
    Model,Eye
     
    Point, 60,  45, 320
     
    Line,  0,    0,   0,  120,   0,  40     ' Bottom
    Line,  120,  0,  40,  120,  90,   0     ' Right side
    Line,  120, 90,   0,    0,  90,  40     ' Top
    Line,  0,   90,  40,    0,   0,   0     ' Left side
     
    Model, Leaves
     
    Line,50,0,0,10,70,100
    Line,50,0,0,110,50,100
    Line,70,90,0,50,20,-100
    Last edited by Arie Verheul; 19 Nov 2008, 08:04 AM. Reason: Compatibilty issues with PBCC 5 corrected

  • #2
    For those of us who don't have the console compiler, but only the windows compiler, could you attach a zip file to a post with an actual EXE file (and the text file) in it.
    Chris Boss
    Computer Workshop
    Developer of "EZGUI"
    http://cwsof.com
    http://twitter.com/EZGUIProGuy

    Comment


    • #3
      1 - This code won't compile with the lattest PBCC.
      2 - This code doesn't work when started from an existing DOS prompt.
      3 - This code does nothing on VISTA.

      ...
      Patrice Terrier
      www.zapsolution.com
      www.objreader.com
      Addons: GDImage.DLL 32/64-bit (Graphic library), WinLIFT.DLL 32/64-bit (Skin Engine).

      Comment


      • #4
        Attachment

        Chris,

        Of course i am prepared to post an attachment with the .exe, but for the moment i am a bit struggling with the forum technology, it just does not seem to work as i want. As soon as this is sorted out i will post the attachment.

        Arie Verheul

        Comment


        • #5
          Missing NEXT Command

          Hi Arie;

          Your code wont compile with PB9 due to an apparently missing NEXT command.

          Comment


          • #6
            The latest versions of the compilers don't allow multiple loops to be terminated with a single NEXT so lines like
            Code:
            NEXT n,m
            must be changed to
            Code:
            NEXT n
            NEXT m

            Also, constants must be defined outside of SUBs/FUNCTIONS so lines like
            Code:
            %SeparationRow = 18
            must all be moved.

            Paul.

            Comment


            • #7
              Compatability note

              Add metastatement #BREAK ON if compiled with PBCC 5

              Arie Verheul

              Comment


              • #8
                Program hangs on my computer

                I'm using PBCC 5.0
                Program doesn't working
                I have deleted your program
                Kind regards
                Stephane

                Comment


                • #9
                  Another compatability issue

                  I did check the issue. and there is indeed another small difference between PBCC 4 and PBCC 5, that makes that the application does not load its settings properly if compiled with PBCC 5.

                  To solve it, search for UpdatePParms "Load" (1 occurrence) and change it to UpdatePParms "L",
                  search for UpdatePParms "Save" (1 occurrence) and change to UpdatePParms "S".

                  Apologies for the inconvenience.

                  Arie Verheul

                  Comment


                  • #10
                    It's almost ok :-)

                    When prog load i have a window centered.
                    I select Load model, i get now a 1/2 sized vertical window.
                    I select one model, and then the window stays 1/2 sized verticaly !

                    Thank's

                    I use window Vista
                    Dominique

                    Comment


                    • #11
                      About Vista

                      Lapgraph was written to use the full screen, as a background of other opened applications quickly
                      causes a messy look. I understood that Vista prevents the use of the full screen.
                      The good thing is that you get at least something on the screen, the bad thing is that i do not
                      use Vista, and therefore cannot assist to solve it, if that would be possible at all.
                      The window setup is handled in the sub SetGraphicWindow, and you can make changes to that without
                      too much risk, as long as the subclassing remains intact.
                      If you find a solution please let me know.

                      Arie Verheul

                      Comment


                      • #12
                        Updated version

                        The code in this thread has been replaced by an updated version intended for both PBCC 4 + 5
                        which has been posted at http://www.powerbasic.com/support/pb...175#post307175

                        Arie Verheul

                        Comment

                        Working...
                        X