Tweet
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)
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.
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
Comment