Option Explicit
Public x As Double, y As Double, k As Integer, X1 As Integer, Y1 As Integer
Public X0 As Double, Y0 As Double, Dx As Double, Dy As Double
Public a As Integer, b As Integer, mismatch As Integer, quitjob As Boolean
Public c(15) As String

Sub make_bitmap()
Dim p As Integer, t As Long, s As Long, i As Integer, j As integer
Dim map As String, filenaam As String, proposal as String
Dim m As Integer, bt As Byte, f As Byte, c As Integer

map = "C:\bitmaps\"
On Error GoTo make    'prepare for Error 76: Path not found
ChDir (map)
On Error GoTo 0
t = 64       'letter "A" (equivalent to "a")=65
Do           'determine a unique filename proposal

t = t + 1
filenaam = Dir(map & k & "curve" & Format(Date, "mmdd") & Chr(t) & ".bmp")
Loop Until filenaam = "" Or t = 89
If t <> 89 Then      'last try with letter "Z"

proposal = k & "curve" & Format(Date, "mmdd") & Chr(t)
Else

proposal = ""
End If
filenaam = InputBox("Filename for bitmap (without extension .bmp)", , proposal)
If filenaam = "" Then Exit Sub
filenaam = filenaam & ".bmp"
On Error GoTo make     'prepare for Error 53: File not found
FileCopy map & "Bmphead.", map & filenaam
On Error GoTo 0
Sheets(2).[b13] = filenaam
Open map & filenaam For Binary As #1
t = CInt(X1)
Put #1, 19, X1
t = CInt(Y1)
Put #1, 23, Y1
s = X1 / 8         'line size at 1 bit/pixel
If s = Int(s) Then t = s Else t = Int(s + 1)
t = Y1 * t
Put #1, 35, t
t = t + 62             'file size
Put #1, 3, t
Seek #1, 63
Sheets(1).Select
bt = 0
m = 128                   'mask
For i = Y1 To 1 Step -1   'start at bottom left corner

For j = 1 To X1      'end at top right corner

c = m * Cells(i, j).Interior.ColorIndex - 1
bt = bt Or CByte(c) And CByte(m)
m = m / 2
If m = 0 Then

m = 128
Put #1, , bt
bt = 0
End If
Next j
If m <> 128 Then     'byte incompleted at line finish

Put #1, , bt    ' needs to be saved this way
bt = 0
m = 128
End If
Next i
Close #1
Exit Sub

make:
'construct map and/or header for B&W bitmap
'keep this in, just in case C:\bitmaps\ is ever removed
Select Case Err.Number

Case 76

MkDir (map)
Case 53

Open map & "BMPHEAD." For Binary As #1
For i = 1 To 60 Step 2
j = 0
Put #1, , j
Next i
j = &H4D42
Put #1, 1, j
i = 62
Put #1, 11, i
i = 40
Put #1, 15, i
i = 1
Put #1, 27, i
i = 1
Put #1, 29, i
j = &HB12
Put #1, 39, j
Put #1, 43, j
j = &HFFFF
Put #1, 59, j
Put #1, 61, j
Close #1
End Select
Resume
End Sub


Sub acirkelrs()
Dim i As Integer, j As Integer, i1 As Integer, j1 As Integer
Dim z As Single, inp As String, labels As String
'expand available screen area:
With ActiveWindow

.DisplayHeadings = False
.DisplayHorizontalScrollBar = False
End With
Application.CommandBars("Chart").Visible = False
Application.CommandBars("Drawing").Visible = False

Sheets(1).Select
Application.ScreenUpdating = False  'speed up raster resizing
Cells.Select
'to fit as many points as possible within display size 800x600:
With Selection

.RowHeight = 2
.ColumnWidth = 0.25
End With
'once Workbook is established and saved, delete With ... End With to speed up process

quitjob = False
Cells(1,1).Select
title_off
c(1) = "Carthesian leaf"
c(2) = "Cassinian"
c(3) = "rotated Cassinian"
c(4) = "like Cassinian"
c(5) = "strophoid"
c(6) = "strophoid wrong"
c(7) = "four-leaf"
c(8) = "pear"
c(9) = "konchoid"
c(10) = "Gutschoven"
c(11) = "cardioid"
c(12) = "serpentine"
labels = ""
For i = 1 To 12
labels = labels & i & " = " & c(i) & Chr(13)
Next i

Do
Do

Do

inp = InputBox(labels & Chr(13) & "Please input curve no." & Chr(13) & "(1 - 12)" & Chr(13) & "Add 100 for solution instead of mismatch map")
If inp = "" Then Exit Sub             'accept Cancel
Loop While Asc(inp) < 48 Or Asc(inp) > 63  'accept numbers only
k = CInt(inp)
Loop While k < 1 Or k > 112          'limit to available curves

mismatch = 0
If k > 100 Then

k = k - 100
mismatch = 1
End If
Loop While k > 12

X0 = Sheets(2).[b1]     'starting point
If X0 = 0 Then X0 = -5
Y0 = Sheets(2).[b2]     '(top left corner)
If Y0 = 0 Then Y0 = -3
Dx = Sheets(2).[b3]     'width
If Dx = 0 Then Dx = 10
Dy = Sheets(2).[b4]     'height
If Dy = 0 Then Dy = 6
i1 = Sheets(2).[b7]
If i1 = 0 Then i1 = 1   'hor step on screen
j1 = Sheets(2).[b8]
If j1 = 0 Then j1 = 1   'vert step on screen
X1 = Sheets(2).[b5]                'note max columns=256
If X1 = 0 Then X1 = 256            '    so do not exceed
Y1 = Sheets(2).[b6]                'scroll bar available
If Y1 = 0 Then Y1 = 210            '      so may be more

Cells.Select
With Selection

.ClearContents
.Interior.ColorIndex = 2     'white, don't use xlNone
End With
title_on

'main loop: color the cells of sheet1 like the pixels in a B&W bitmap
Application.ScreenUpdating = True  'watch it fill
For j = 1 To X1 Step j1

For i = 1 To Y1 Step i1

x = X0 + Dx / X1 * j
y = Y0 + Dy / Y1 * i
z = Int(0.5 + beef(k))
If quitjob Then

MsgBox "Unavailable with this mismatch/solution option"
title_off
Exit Sub
End If
If z / 2 = Int(z / 2) Then Cells(i, j).Interior.ColorIndex = 1
Next i
Next j
Sheets(2).[b9] = k
Sheets(2).[b10] = a
Sheets(2).[b11] = b
Sheets(2).[b12] = mismatch
make_bitmap
End Sub


Function beef(curve As Integer) As Single
if mismatch = 0 Then

Select Case curve
'function solved for (one) constant; i.e. beef = value of constant to place point (x,y) on curve
'different constants a and b yield different results
Case 1

'carthesian leaf
If x * y = 0 Then beef = 1 Else beef = (x * x * x + y * y * y) / x / y
Case 2

'cassinian curve
If (x * x - y * y) =0 Then
beef = 1
Else
beef = (x * x + y * y) * (x * x + y * y) / (x * x - y * y)
End If
Case 5

'strophoid
a = 4
If x = 0 Or x + a = 0 Then beef = -1 Else beef = (a - x) * y * y / (a + x) / x / x
Case 6

'strophoid-like with errors ( * instead of / )
a = 4
If x = 0 Or x + a = 0 Then beef = -1 Else beef = (a - x) * y * y / (a + x) * x * x
Case 7

'four-leaf
If x * y = 0 Then beef = 1 Else beef = (x * x + y * y) * (x * x + y * y) * (x * x + y * y) / (x * x * y * y)
Case 8

'Pear
a = 3
If x = 0 Or x = a Then beef = 1 Else beef = y * y / (x * x * x * (a - x))
Case 9

'konchoid (shell curve)
a = 4
If x = 0 Then beef = 1 Else beef = (x * x + y * y) * (x - a) * (x - a) / a * a / x / x
Case 10

'Gutschoven
If x = 0 Then beef = 1 Else beef = y * y * (x * x + y * y) / (x * x)
Case 11

'cardioid
a = 8
If x * y = 0 Then beef = 1 Else beef = (y * y + x * x - 2 * a * x) * (y * y + x * x - 2 * a * x) / ((x * x + y * y) * 4 * a * a)
Case 12

'Serpentine
a =2
If y = 1 Then beef = 1 Else beef = (x * x * y - a * a * x) / a / (y - 1)
Case Else

quitjob = True
End Select

Else

'mismatch = 1
Select Case curve
'if beef = 0 , point (x,y) fits curve; i.e. beef = fitting error or amount of mismatch
'different constants a and b yield different results
Case 1

'carthesian leaf
a = 3
If x * y = 0 Then beef = 1 Else beef = (x * x * x + y * y * y) - 3 * a * x * y
Case 2

'cassinian curve
a = 10
beef = (x * x + y * y) * (x * x + y * y) - (x * x - y * y) * a
Case 3

'cassinian curve: (rotated)
a = 10
beef = (x * x + y * y) * (x * x + y * y) + (x * x - y * y) * a
Case 4

'variation on cassinian curve
beef = (x * x + y * y) * (x * x + y * y) - (x * x - y * y) * (x * x - y * y) * 2
Case 5

'strophoid
a = 4
beef = (a - x) * y * y - (a + x) * x * x
Case 6

'strophoid-like with errors ( / instead of * )
a = 4
If x = 0 Or x + a = 0 Then beef = -1 Else beef = (a - x) * y * y - (a + x) / x / x
Case 7

'four-leaf
a = 4
If x * y = 0 Then beef = 1 Else beef = (x * x + y * y) * (x * x + y * y) * (x * x + y * y) - 4 * a * a * x * x * y * y
Case 8

'Pear
a = 13
b = 2
beef = b * b * y * y - x * x * x * (a - x)
Case 9

'konchoid (shell curve)
a = 4
If x = 0 Then beef = 1 Else beef = (x * x + y * y) * (x - a) * (x - a) - a * a * x * x
Case 10

'Gutschoven
a = 2
beef = y * y * (x * x + y * y) - a * x * a * x
Case 11

'cardioid
a = 4
If x * y = 0 Then beef = 1 Else beef = (y * y + x * x - 2 * a * x) * (y * y + x * x - 2 * a * x) - (x * x + y * y) * 4 * a * a
Case 12

'Serpentine
a = -1
b = 2
beef = x * x * y + a * b * y - a * a * x
Case Else

quitjob = True
End Select
End If
End Function


Sub title_off()

'automatic provisions on first run
ActiveWindow.DisplayHeadings = False
    'remove row and column headers to increase worksheet window size
Dim myDocument As Object, sh As Object, i As Integer
Set myDocument = Worksheets(1)
i = 0
For Each sh In myDocument.Shapes

i = i + 1
Next
If i = 0 Then     'no shapes yet, hence first run

'automatic provision of textbox for label
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 260, 294, 88, 16).Select
Selection.Characters.Text = ""
With Selection

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.OnAction = "title_off"      'assign macro
' i.e. clicking on title box will turn it off
End With
'automatic provision in sheet2 of legend for bitmap parameters you may want to keep
Sheets(2).[a1] = "start x"
Sheets(2).[a2] = "start y"
Sheets(2).[a3] = "delta x"
Sheets(2).[a4] = "delta y"
Sheets(2).[a5] = "screen h"
Sheets(2).[a6] = "screen v"
Sheets(2).[a7] = "step h"
Sheets(2).[a8] = "step v"
Sheets(2).[a9] = "curve"
Sheets(2).[a10] = "a"
Sheets(2).[a11] = "b"
Sheets(2).[a12] = "mismatch"
Sheets(2).[a13] = "bitmap"
End If
'once Workbook is established and saved, the above provisions may be deleted
'then this sub contains only the following one line
ActiveSheet.Shapes("Text box 1").Visible = False
End Sub


Sub title_on()

ActiveSheet.Shapes("Text box 1").Visible = True
ActiveSheet.Shapes("Text Box 1").Select
With Selection

.Characters.Text = k & " " & c(k)
.AutoSize = True
End With
Cells(Y1 + 1, X1).Select       'outside picture area
End Sub