08-02-2022, 09:58 PM
(This post was last modified: 08-03-2022, 12:11 PM by James D Jarvis.)
here's the 256 color CMYK version that technically isn't really screen mode 0. There's some expanded functionality in here that will be wrapped into the original program eventually.
Code: (Select All)
'256 color CMYK version of textdrawing still early in development
'by James D. Jarvis
'
'text graphics drawing
'this is ugly and incomplete but I felt it woudl be fun to share inprogress
'let's use a screen larger than standard text mode usually is to have room to draw an image and have some controls on a screen
' when you esc to quit a bunch of noise shows up on the program for now, don't worry about that now... I'm not.
Screen _NewImage(1140, 600, 256)
Type texteltype
char As String * 1
fc As Integer
bc As Integer
End Type
Dim Shared fklr, bklr
Dim Shared px, py, pup$, pdown$, showbar$, pmode, themode$(4)
Dim Shared cpos(255, 2), bkpick(255, 2)
Dim Shared maxtx, maxty
Dim tchar, tfc, tbc
'added feature in this version
'setup drawing modes
themode$(1) = "all" 'all charcteristic of painted cell will change
themode$(2) = "colorfg" 'only foreground color will change
themode$(3) = "colorbg" 'only background colot will change
themode$(4) = "only CHR" 'onlt character will change
'maximum text x and maximum text y for the text graphics image
'hardcoded for now, eventually going be a user enetered value
maxtx = 64
maxty = 24
Dim Shared grid(maxtx, maxty, 3)
Dim Shared tgraphic(maxtx, maxty) As texteltype
Dim Shared traw$
'traw$ is just a test value for now as I experiment with ways to convert from string to image
'tgraphic stores the text graphic while in progress
traw$ = ""
traw$ = traw$ + Chr$(32 + xaxtx)
traw$ = traw$ + Chr$(32 + xaxty)
For x = 1 To maxtx
For y = 1 To maxty
tgraphic(x, y).char = " "
tgraphic(x, y).fc = 0
tgraphic(x, y).bc = 0
traw$ = traw$ + tgraphic(x, y).char + Chr$(32) + Chr$(32)
Next
Next
_ControlChr Off ' i want to be able to show those unprintables
'this builds a reference array for the characters being drawn so they can be selected by a mouse click
' and gets theselectiongrid drawn in the first palce
cx = 131: cy = 5
For c = 1 To 255
_Limit 512
_PrintString (cx * 8 - 7, cy * 16 - 15), Chr$(c)
cpos(c, 1) = cx
cpos(c, 2) = cy
cx = cx + 1
If cx > 140 Then
cx = 131
cy = cy + 1
End If
Next c
xx = 0
yy = 3
For b = 0 To 255
bkpick(b, 2) = yy
bkpick(b, 1) = xx + 114
xx = xx + 1
If xx = 16 Then
xx = 0
yy = yy + 1
End If
Color b
_PrintString (bkpick(b, 1) * 8 - 7, bkpick(b, 2) * 16 - 15), Chr$(219)
Next b
Color 15
For x = 1 To maxtx
For y = 1 To maxty
grid(x, y, 1) = x
grid(x, y, 2) = y + 5
Next
Next
pdown$ = "yes" 'hmmmm.... not using this yet
px = 1: py = 1
pno = 34
pchar$ = Chr$(pno)
fklr = 15: bklr = 0
showbar$ = "yes"
colorselect$ = "b"
pmode = 1
'yup i like cmyk colors, this will work fine in stabdard rgb by commenting out the next line
loadCMYK
'the following two lines call simple subs that draw a border to show the saize of the drawing area
'it can be turned on and off with the \ key
draw_xbar
draw_ybar
Do
_Limit 60
kk$ = InKey$
Locate 2, 2
Print px; ";"; py
Color fklr, 0
Locate 3, 3
Print Chr$(219)
Color bklr, bklr
Locate 3, 5
Print Chr$(219)
Color 15, 0
Locate 3, 7
Print Chr$(pno)
Do While _MouseInput
x = 1 + Int(_MouseX / 8)
y = 1 + Int(_MouseY / 16)
'check for the mouse pointer in the image drawing area
If x > 0 And x <= maxtx And y > 5 And y <= maxty + 5 Then
If _MouseButton(1) Then
If pmode = 1 Then 'change all attributes
Color fklr, bklr
_PrintString (x * 8 - 7, y * 16 - 15), pchar$
tgraphic(x, y - 5).fc = fklr
tgraphic(x, y - 5).bc = bklr
tgraphic(x, y - 5).char = pchar$
End If
If pmode = 2 Then 'only change foreground color
Color fklr, tgraphic(x, y - 5).bc
_PrintString (x * 8 - 7, y * 16 - 15), tgraphic(x, y - 5).char
tgraphic(x, y - 5).fc = fklr
End If
If pmode = 3 Then 'only change background color
Color tgraphic(x, y - 5).fc, bklr
_PrintString (x * 8 - 7, y * 16 - 15), tgraphic(x, y - 5).char
tgraphic(x, y - 5).bc = bklr
End If
If pmode = 4 Then 'only change character
Color tgraphic(x, y - 5).fc, tgraphic(x, y - 5).bc
_PrintString (x * 8 - 7, y * 16 - 15), pchar$
tgraphic(x, y - 5).char = pchar$
End If
Color 15, 0
px = x
py = y - 5
End If
End If
'check to see which character is clicked in the character selection area or the background colorbar
If x > 113 And x < 130 And y > 2 And y < 19 Then
If _MouseButton(1) Then
For b = 0 To 255
If x = bkpick(b, 1) And y = bkpick(b, 2) Then
If colorselect$ = "b" Then bklr = b
If colorselect$ = "f" Then fklr = b
End If
Next b
End If
End If
If x > 130 And x < 141 And y > 0 And y < 41 Then
If _MouseButton(1) Then
For cc = 1 To 255
If x = cpos(cc, 1) And y = cpos(cc, 2) Then
'refresh the character selection display so the one selected is highlighted by blinking
For c = 1 To 255
_Limit 4000
_PrintString (cpos(c, 1) * 8 - 7, cpos(c, 2) * 16 - 15), Chr$(c)
Next c
pno = cc
pchar$ = Chr$(pno)
Color 31, 8
_PrintString (x * 8 - 7, y * 16 - 15), pchar$
Color 15, 0
End If
Next cc
End If
End If
Loop
Locate 1, 1: Print x, y
' drawing with the numerical keypad is possible but the mouse really is better
Select Case kk$
Case "1", "!"
If py < maxty Then py = py + 1
If px > 1 Then px = px - 1
Case "2", "@"
If py < maxty Then py = py + 1
Case "3", "#"
If py < maxty Then py = py + 1
If px > 1 Then px = px + 1
Case "4", "$"
If px > 1 Then px = px - 1
Case "5", "%", " "
Case "6", "^"
If px < maxtx Then px = px + 1
Case "7", "&"
If py > 1 Then py = py - 1
If px > 1 Then px = px - 1
Case "8", "*"
If py > 1 Then py = py - 1
Case "9", "("
If py > 1 Then py = py - 1
If px < maxtx Then px = px + 1
Case "u", "U"
Case "d", "D"
Case "c", "C" 'change the character
'this just cycles through the character code
_PrintString (cpos(pno, 1), cpos(pno, 2)), pchar$
pno = pno + 1
If pno > 255 Then pno = 1
pchar$ = Chr$(pno)
Color 31, 8
_PrintString (cpos(pno, 1), cpos(pno, 2)), pchar$
Color 15, 0
Case "b", "B" 'change the background color
colorselect$ = "b"
Case "f", "F" 'change the foreground color
colorselect$ = "f"
Case " "
Case "\" 'sizebar on and off
If showbar$ = "yes" Then
showbar$ = "no"
Else
showbar$ = "yes"
End If
draw_xbar
draw_ybar
Case "p", "P" 'paint fill
x = 1 + Int(_MouseX / 8)
y = 1 + Int(_MouseY / 16)
ppx = x: ppy = y - 5
tchar$ = tgraphic(ppx, ppy).char
tfc = tgraphic(ppx, ppy).fc
tbc = tgraphic(ppx, ppy).bc
paintit$ = "paint"
For tx = ppx To maxtx
For ty = ppy To maxty
If tchar$ = tgraphic(tx, ty).char And paintit$ = "paint" Then
tgraphic(tx, ty).char = pchar$
tgraphic(tx, ty).fc = fklr
tgraphic(tx, ty).bc = bklr
_PrintString (tx * 8 - 7, (ty + 5) * 16 - 15), pchar$
Else
paintit$ = "no"
End If
Next
Next
Case "m", "M" 'change draw mode
pmode = pmode + 1
If pmode = 5 Then pmode = 1
Locate 3, 15
Print " "
Locate 3, 15
Print themode$(pmode)
End Select
If kk$ >= "1" And kk$ <= "9" Or kk$ = " " Then
Locate grid(px, py, 2), grid(px, py, 1)
Color fklr, bklr
Print pchar$
Color 15, 0
End If
Loop Until kk$ = Chr$(27)
traw$ = tgraphictostring$
'this secetion of code is just to see how the different subs are working, nothing good but it is a great example of
' how i code when i don't plan, constantly writing diagonostic routines to see if I'm hadnling things like i think I am
Color 15, 0
Cls
Locate 1, 1
Print traw$
Print "bye"
draw_tgraphic 10, 10
draw_tgraphic 30, 10
Function tgraphictostring$
'not so keen on this yet
tt$ = ""
tt$ = tt$ + Chr$(32 + xaxtx)
tt$ = tt$ + Chr$(32 + xaxty)
For x = 1 To maxtx
For y = 1 To maxty
tt$ = tt$ + tgraphic(x, y).char + Chr$(32 + tgraphic(x, y).fc) + Chr$(32 + tgraphic(x, y).fc)
Next
Next
tgraphictostring$ = tt$
End Function
Function texttotgraphic (tt$)
Print tt$
maxtx = Asc(Mid$(tt$, 1, 1)) - 32
maxty = Asc(Mid$(tt$, 2, 1)) - 32
tsize = (maxtx * maxtx)
x = 0: y = 1
For c = 1 To tsize
cc = c * 3
x = x + 1
If x > maxtx Then
x = 1
y = y + 1
End If
tgraphic(x, y).char = Mid$(tt$, cc, 1)
tgraphic(x, y).fc = Asc(Mid$(tt$, cc + 1, 1)) - 32
tgraphic(x, y).bc = Asc(Mid$(tt$, cc + 2, 1)) - 32
Print tgraphic(x, y).char;
Next c
End Function
Sub draw_xbar
xby = 5
Locate 5, 1
For xbx = 1 To maxtx
If xbx Mod 2 = 0 Then
If showbar$ = "yes" Then
_PrintString (xbx * 8 - 7, xby * 16 - 15), "-"
Else
_PrintString (xbx * 8 - 7, xby * 16 - 15), " "
End If
Else
If showbar$ = "yes" Then
_PrintString (xbx * 8 - 7, xby * 16 - 15), "+"
Else
_PrintString (xbx * 8 - 7, xby * 16 - 15), " "
End If
End If
Next
End Sub
Sub draw_ybar
xbx = maxtx + 1
For xby = 1 To maxty
If xby Mod 2 = 0 Then
If showbar$ = "yes" Then
_PrintString (xbx * 8 - 7, (xby + 5) * 16 - 15), "-"
Else
_PrintString (xbx * 8 - 7, (xby + 5) * 16 - 15), " "
End If
Else
Locate 5 + b, maxtx + 1
If showbar$ = "yes" Then
_PrintString (xbx * 8 - 7, (xby + 5) * 16 - 15), "+"
Else
_PrintString (xbx * 8 - 7, (xby + 5) * 16 - 15), " "
End If
End If
Next
End Sub
Sub draw_tgraphic (XX, YY)
'this works.... I think
For x = 1 To maxtx
For y = 1 To maxty
Color tgraphic(x, y).fc, tgraphic(x, y).bc
_PrintString (XX - 1 + x, YY - 1 + y), tgraphic(x, y).char
Next
Next
Color 15, 0
End Sub
Sub loadCMYK
'build a cmyk palete
'this palete contains set of colors in 20 increment blocks (except for the last 15)
klr = 0
c = 0
m = 0
y = 0
k = 0
For klr = 0 To 255
Select Case klr
Case 1 TO 20 'lightest grey to black in 5% increments
k = k + 5
c = 0
m = 0
y = 0
Case 21 TO 40 'cyan on white in 5% increments
k = 0
c = c + 5
m = 0
y = 0
Case 41 TO 60 'magenta on white in 5% increments
k = 0
c = 0
m = m + 5
y = 0
Case 61 TO 80 'yellow on white in 5% increments
k = 0
c = 0
m = 0
y = y + 5
Case 81 TO 100 'cyan and magenta on white in 5% increments
k = 0
c = c + 5
m = m + 5
y = 0
Case 101 TO 120 'cyan and yellow on white in 5% increments
If klr = 101 Then c = 0
k = 0
c = c + 5
m = 0
y = y + 5
Case 121 TO 140 'magenta and yellow on white in 5% increments
If klr = 121 Then y = 0
k = 0
c = 0
m = m + 5
y = y + 5
Case 121 TO 140 'cyan and magenta in 5% increments with 20% black
If klr = 121 Then m = 0
k = 20
c = c + 5
m = m + 5
y = 0
Case 141 TO 160 'cyan and yellow in 5% increments with 20% black
If klr = 141 Then c = 0
k = 20
c = c + 5
m = 0
y = y + 5
Case 161 TO 180 'magenta and yellow in 5% increments with 20% black, pink to red
If klr = 161 Then y = 0
k = 20
c = 0
m = m + 5
y = y + 5
Case 181 TO 200
If klr = 181 Then m = 0
k = 40
c = c + 5
m = m + 5
y = 0
Case 201 TO 220
If klr = 201 Then c = 0
k = 40
c = c + 5
m = 0
y = y + 5
Case 221 TO 240 'mauves
If klr = 221 Then y = 0
k = 40
c = 0
m = m + 5
y = y + 5
Case 241 TO 255 'tans and browns
k = 10 + (klr - 240) * 4
c = 0
'm = 100
m = klr - 200
y = y + 5
End Select
pal_cmyk klr, c, m, y, k
Next klr
End Sub
Sub pal_cmyk (pk, c, m, y, k)
' create a 256 color palette entry using CMYK
' CMYK process color Cyan, Magenta, Yellow, Black each expressed as a percent from 0 to 100
r = 255 * (100 - c)
r = (r / 100) * ((100 - k) / 100)
g = 255 * (100 - m)
g = (g / 100) * ((100 - k) / 100)
b = 255 * (100 - y)
b = (b / 100) * ((100 - k) / 100)
_PaletteColor pk, _RGB32(r, g, b)
End Sub