Posts: 688
Threads: 154
Joined: Apr 2022
Reputation:
67
09-23-2023, 12:02 AM
(This post was last modified: 09-23-2023, 01:24 PM by James D Jarvis.)
cprint and cfprint are 2 text mode routines that allow printing to specific location on a text screen (or text image) with colored text without changing global text values. cfprint prints in just a foreground text color without changing the existing background color at the location simulating a part of _printmode _keepbackground.
there is also an "internal function" thebit$ that extracts a row of bits from a starting position to an end postion in a value. It is used here to read the background color for cfprint.
Code: (Select All) Sub cprint (x, y, fg, bg, txt$)
'print color text txt$ at location x,y color fg,bg without altering global color values
'txt$ may contain control characters without using _controlchr
'use on screen mode 0 screens only
Dim o As _MEM
ii& = _Dest
o = _MemImage(ii&)
w = (_Width(ii&)) * 2
ts = (y - 1) * w + (x - 1) * 2
n = 0
If fg > 15 Then
ff = fg - 16
bb = 1
Else
ff = fg
bb = 0
End If
c = bb * 128 + ff + bg * 16
For cx = 1 To Len(txt$)
v = Asc(Mid$(txt$, cx, 1))
_MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
_MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
Next cx
_MemFree o
End Sub
Sub cfprint (x, y, fg, txt$)
'print color text txt$ at location x,y color fg without altering global color values or background colors under txt$
'txt$ may contain control characters without using _controlchr
'this simulates some of the behavior of _printmode _keepbackground
'use on screen mode 0 screens only
Dim o As _MEM
ii& = _Dest
o = _MemImage(ii&)
w = (_Width(ii&)) * 2
ts = (y - 1) * w + (x - 1) * 2
n = 0
If fg > 15 Then
ff = fg - 16
bb = 1
Else
ff = fg
bb = 0
End If
For cx = 1 To Len(txt$)
v = Asc(Mid$(txt$, cx, 1))
c1 = _MemGet(o, o.OFFSET + ts + (cx - 1) * 2 + 1, _Unsigned _Byte)
ccb$ = thebit$(c1, 6, 4)
bg = Val("&B" + ccb$)
c = bb * 128 + ff + bg * 16
_MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
_MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
Next cx
_MemFree o
End Sub
Function thebit$ (n, sb, eb)
'grabs bits from starting bit SB to end bit eb
If eb > sb Then Exit Function
a$ = ""
For b = sb To eb Step -1
If _ReadBit(n, b) = 0 Then a$ = a$ + "0" Else a$ = a$ + "1"
Next b
thebit$ = a$
End Function
Posts: 4,698
Threads: 222
Joined: Apr 2022
Reputation:
322
(09-23-2023, 12:02 AM)James D Jarvis Wrote: cprint and cfprint are 2 text mode routines that allow printing to specific location on a text screen (or text image) with colored text without changing global text values. cfprint prints in just a foreground text color without changing the existing background color at the location simulating a part of _printmode _keepbackground.
there is also an "internal function" thebit$ that extracts a row of bits from a starting position to an end postion in a value. It is used here to read the background color for cfprint.
Code: (Select All) Sub cprint (x, y, fg, bg, txt$)
'print color text txt$ at location x,y color fg,bg without altering global color values
'txt$ may contain control characters without using _controlchr
'use on screen mode 0 screens only
Dim o As _MEM
ii& = _Dest
o = _MemImage(ii&)
w = (_Width(ii&)) * 2
ts = (y - 1) * w + (x - 1) * 2
n = 0
If fg > 15 Then
ff = fg - 16
bb = 1
Else
ff = fg
bb = 0
End If
c = bb * 128 + ff + bg * 16
For cx = 1 To Len(txt$)
v = Asc(Mid$(txt$, cx, 1))
_MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
_MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
Next cx
_MemFree o
End Sub
Sub cfprint (x, y, fg, txt$)
'print color text txt$ at location x,y color fg without altering global color values or background colors under txt$
'txt$ may contain control characters without using _controlchr
'this simulates some of the behavior of _printmode _keepbackground
'use on screen mode 0 screens only
Dim o As _MEM
ii& = _Dest
o = _MemImage(ii&)
w = (_Width(ii&)) * 2
ts = (y - 1) * w + (x - 1) * 2
n = 0
If fg > 15 Then
ff = fg - 16
bb = 1
Else
ff = fg
bb = 0
End If
For cx = 1 To Len(txt$)
v = Asc(Mid$(txt$, cx, 1))
c1 = _MemGet(o, o.OFFSET + ts + (cx - 1) * 2 + 1, _Unsigned _Byte)
ccb$ = thebit$(c1, 6, 4)
bg = Val("&B" + ccb$)
c = bb * 128 + ff + bg * 16
_MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
_MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
Next cx
_MemFree o
End Sub
Function thebit$ (n, sb, eb)
'grabs bits from starting bit SB to end bit eb
If eb > sb Then Exit Function
a$ = ""
For b = sb To eb Step -1
If _ReadBit(n, b) = 0 Then a$ = a$ + "0" Else a$ = a$ + "1"
Next b
thebit$ = a$
End Function
Ah might be handy to replace Color + Locate + Print, do it in one statement.
Have you tested the memory helper routine against standard 3 above in a timed test?
I'd be interested in results.
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 688
Threads: 154
Joined: Apr 2022
Reputation:
67
09-23-2023, 06:20 PM
(This post was last modified: 09-23-2023, 06:21 PM by James D Jarvis.)
It's not the speediest. May be able to improve it but I'd say it's still useable.
results from my machine on a simple test.
![[Image: image.png]](https://i.ibb.co/jbvSx5s/image.png)
that works out to about 1,000 pages a second for the slowest method on my machine.
Code: (Select All) 'don't forget to add the subroutines if you want to test it on your computer
t1 = Timer
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
Color c, b
Locate y, x
Print Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t2 = Timer
Color 15, 0
t3 = Timer
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
cprint x, y, c, b, Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t4 = Timer
t5 = Timer
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
cfprint x, y, c, Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t6 = Timer
Posts: 3,448
Threads: 376
Joined: Apr 2022
Reputation:
345
Remember, for speed, you can turn $CHECKING:OFF with mem to see a noticeable speed boost.
$CHECKING:OFF
_MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
_MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
$CHECKING:ON
Posts: 4,698
Threads: 222
Joined: Apr 2022
Reputation:
322
(09-23-2023, 06:20 PM)James D Jarvis Wrote: It's not the speediest. May be able to improve it but I'd say it's still useable.
results from my machine on a simple test.
that works out to about 1,000 pages a second for the slowest method on my machine.
Code: (Select All) 'don't forget to add the subroutines if you want to test it on your computer
t1 = Timer
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
Color c, b
Locate y, x
Print Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t2 = Timer
Color 15, 0
t3 = Timer
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
cprint x, y, c, b, Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t4 = Timer
t5 = Timer
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
cfprint x, y, c, Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t6 = Timer
ah this code is missing the display of results. I think timer(.001) gives us best precision unless mistaken about timer arguments.
Still checking out code....
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 3,448
Threads: 376
Joined: Apr 2022
Reputation:
345
Change:
v = Asc(Mid$(txt$, cx, 1))
To:
v = ASC(txt$, cx)
Posts: 4,698
Threads: 222
Joined: Apr 2022
Reputation:
322
OK I am getting original code as fastest:
Code: (Select All) 'don't forget to add the subroutines if you want to test it on your computer
t1 = Timer(.001)
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
Color c, b
Locate y, x
Print Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t2 = Timer(.001)
Color 15, 0
t3 = Timer(.001)
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
cprint x, y, c, b, Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t4 = Timer(.001)
t5 = Timer(.001)
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
cfprint x, y, c, Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t6 = Timer(.001)
Print t2 - t1
Print t4 - t3
Print t6 - t5
' jarvis subs we are testing
Sub cprint (x, y, fg, bg, txt$)
'print color text txt$ at location x,y color fg,bg without altering global color values
'txt$ may contain control characters without using _controlchr
'use on screen mode 0 screens only
Dim o As _MEM
ii& = _Dest
o = _MemImage(ii&)
w = (_Width(ii&)) * 2
ts = (y - 1) * w + (x - 1) * 2
n = 0
If fg > 15 Then
ff = fg - 16
bb = 1
Else
ff = fg
bb = 0
End If
c = bb * 128 + ff + bg * 16
For cx = 1 To Len(txt$)
v = Asc(Mid$(txt$, cx, 1))
_MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
_MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
Next cx
_MemFree o
End Sub
Sub cfprint (x, y, fg, txt$)
'print color text txt$ at location x,y color fg without altering global color values or background colors under txt$
'txt$ may contain control characters without using _controlchr
'this simulates some of the behavior of _printmode _keepbackground
'use on screen mode 0 screens only
Dim o As _MEM
ii& = _Dest
o = _MemImage(ii&)
w = (_Width(ii&)) * 2
ts = (y - 1) * w + (x - 1) * 2
n = 0
If fg > 15 Then
ff = fg - 16
bb = 1
Else
ff = fg
bb = 0
End If
For cx = 1 To Len(txt$)
v = Asc(Mid$(txt$, cx, 1))
c1 = _MemGet(o, o.OFFSET + ts + (cx - 1) * 2 + 1, _Unsigned _Byte)
ccb$ = thebit$(c1, 6, 4)
bg = Val("&B" + ccb$)
c = bb * 128 + ff + bg * 16
_MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
_MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
Next cx
_MemFree o
End Sub
Function thebit$ (n, sb, eb)
'grabs bits from starting bit SB to end bit eb
If eb > sb Then Exit Function
a$ = ""
For b = sb To eb Step -1
If _ReadBit(n, b) = 0 Then a$ = a$ + "0" Else a$ = a$ + "1"
Next b
thebit$ = a$
End Function
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,698
Threads: 222
Joined: Apr 2022
Reputation:
322
09-23-2023, 06:45 PM
(This post was last modified: 09-23-2023, 06:49 PM by bplus.)
(09-23-2023, 06:40 PM)SMcNeill Wrote: Change:
v = Asc(Mid$(txt$, cx, 1))
To:
v = ASC(txt$, cx)
aye may take more than this?
Any improvement?
Code: (Select All) 'don't forget to add the subroutines if you want to test it on your computer
t1 = Timer(.001)
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
Color c, b
Locate y, x
Print Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t2 = Timer(.001)
Color 15, 0
t3 = Timer(.001)
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
cprint x, y, c, b, Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t4 = Timer(.001)
t5 = Timer(.001)
For r = 1 To 100
For b = 0 To 7
For c = 0 To 31
For y = 1 To 20
For x = 1 To 26
cfprint x, y, c, Chr$(x + 64)
Next x
Next y
Next c
Next b
Next r
t6 = Timer(.001)
Print t2 - t1
Print t4 - t3
Print t6 - t5
' jarvis subs we are testing
Sub cprint (x, y, fg, bg, txt$)
'print color text txt$ at location x,y color fg,bg without altering global color values
'txt$ may contain control characters without using _controlchr
'use on screen mode 0 screens only
Dim o As _MEM
ii& = _Dest
o = _MemImage(ii&)
w = (_Width(ii&)) * 2
ts = (y - 1) * w + (x - 1) * 2
n = 0
If fg > 15 Then
ff = fg - 16
bb = 1
Else
ff = fg
bb = 0
End If
c = bb * 128 + ff + bg * 16
For cx = 1 To Len(txt$)
v = Asc(txt$, cx)
_MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
_MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
Next cx
_MemFree o
End Sub
Sub cfprint (x, y, fg, txt$)
'print color text txt$ at location x,y color fg without altering global color values or background colors under txt$
'txt$ may contain control characters without using _controlchr
'this simulates some of the behavior of _printmode _keepbackground
'use on screen mode 0 screens only
Dim o As _MEM
ii& = _Dest
o = _MemImage(ii&)
w = (_Width(ii&)) * 2
ts = (y - 1) * w + (x - 1) * 2
n = 0
If fg > 15 Then
ff = fg - 16
bb = 1
Else
ff = fg
bb = 0
End If
For cx = 1 To Len(txt$)
v = Asc(txt$, cx)
c1 = _MemGet(o, o.OFFSET + ts + (cx - 1) * 2 + 1, _Unsigned _Byte)
ccb$ = thebit$(c1, 6, 4)
bg = Val("&B" + ccb$)
c = bb * 128 + ff + bg * 16
_MemPut o, o.OFFSET + ts + (cx - 1) * 2, v As _UNSIGNED _BYTE
_MemPut o, o.OFFSET + ts + (cx - 1) * 2 + 1, c As _UNSIGNED _BYTE
Next cx
_MemFree o
End Sub
Function thebit$ (n, sb, eb)
'grabs bits from starting bit SB to end bit eb
If eb > sb Then Exit Function
a$ = ""
For b = sb To eb Step -1
If _ReadBit(n, b) = 0 Then a$ = a$ + "0" Else a$ = a$ + "1"
Next b
thebit$ = a$
End Function
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 3,448
Threads: 376
Joined: Apr 2022
Reputation:
345
(09-23-2023, 06:45 PM)bplus Wrote: aye may take more than this?
Give this a shot and see how it compares for speed:
Code: (Select All)
CONST limit = 1000000
PRINT "Let's do some time tests!"
PRINT "Running cprint "; limit; "times!"
t## = TIMER
FOR i = 1 TO limit
x = INT(RND * 70) + 1
y = INT(RND * 20) + 1
cprint x, y, INT(RND * 32), INT(RND * 16), "CPRINT!!"
NEXT
t1## = TIMER
CLS
PRINT "Running cprintFAST "; limit; "times!"
t2## = TIMER
FOR i = 1 TO limit
x = INT(RND * 65) + 1
y = INT(RND * 20) + 1
cprintFAST x, y, INT(RND * 32), INT(RND * 16), "CPRINTFAST!!"
NEXT
t3## = TIMER
CLS
PRINT "Running cfprint "; limit; "times!"
t4## = TIMER
FOR i = 1 TO limit
x = INT(RND * 70) + 1
y = INT(RND * 20) + 1
cfprint x, y, INT(RND * 32), "CPRINT!!"
NEXT
t5## = TIMER
CLS
PRINT "Running cfprintFAST "; limit; "times!"
t6## = TIMER
FOR i = 1 TO limit
x = INT(RND * 65) + 1
y = INT(RND * 20) + 1
cfprintFAST x, y, INT(RND * 32), "CPRINTFAST!!"
NEXT
t7## = TIMER
LOCATE 21, 1
PRINT "Printing results for"; limit; "runs:"
PRINT USING "###.###### seconds for cprint"; t1## - t##
PRINT USING "###.###### seconds for cprintFAST"; t3## - t2##
PRINT USING "###.###### seconds for cprint"; t5## - t4##
PRINT USING "###.###### seconds for cprintFAST"; t7## - t6##
SUB cprint (x, y, fg, bg, txt$)
'print color text txt$ at location x,y color fg,bg without altering global color values
'txt$ may contain control characters without using _controlchr
'use on screen mode 0 screens only
DIM o AS _MEM
ii& = _DEST
o = _MEMIMAGE(ii&)
w = (_WIDTH(ii&)) * 2
ts = (y - 1) * w + (x - 1) * 2
n = 0
IF fg > 15 THEN
ff = fg - 16
bb = 1
ELSE
ff = fg
bb = 0
END IF
c = bb * 128 + ff + bg * 16
FOR cx = 1 TO LEN(txt$)
v = ASC(MID$(txt$, cx, 1))
_MEMPUT o, o.OFFSET + ts + (cx - 1) * 2, v AS _UNSIGNED _BYTE
_MEMPUT o, o.OFFSET + ts + (cx - 1) * 2 + 1, c AS _UNSIGNED _BYTE
NEXT cx
_MEMFREE o
END SUB
SUB cfprint (x, y, fg, txt$)
'print color text txt$ at location x,y color fg without altering global color values or background colors under txt$
'txt$ may contain control characters without using _controlchr
'this simulates some of the behavior of _printmode _keepbackground
'use on screen mode 0 screens only
DIM o AS _MEM
ii& = _DEST
o = _MEMIMAGE(ii&)
w = (_WIDTH(ii&)) * 2
ts = (y - 1) * w + (x - 1) * 2
n = 0
IF fg > 15 THEN
ff = fg - 16
bb = 1
ELSE
ff = fg
bb = 0
END IF
FOR cx = 1 TO LEN(txt$)
v = ASC(MID$(txt$, cx, 1))
c1 = _MEMGET(o, o.OFFSET + ts + (cx - 1) * 2 + 1, _UNSIGNED _BYTE)
ccb$ = thebit$(c1, 6, 4)
bg = VAL("&B" + ccb$)
c = bb * 128 + ff + bg * 16
_MEMPUT o, o.OFFSET + ts + (cx - 1) * 2, v AS _UNSIGNED _BYTE
_MEMPUT o, o.OFFSET + ts + (cx - 1) * 2 + 1, c AS _UNSIGNED _BYTE
NEXT cx
_MEMFREE o
END SUB
FUNCTION thebit$ (n, sb, eb)
'grabs bits from starting bit SB to end bit eb
IF eb > sb THEN EXIT FUNCTION
a$ = ""
FOR b = sb TO eb STEP -1
IF _READBIT(n, b) = 0 THEN a$ = a$ + "0" ELSE a$ = a$ + "1"
NEXT b
thebit$ = a$
END FUNCTION
$CHECKING:OFF
SUB cprintFAST (x, y, fg, bg, txt$)
'print color text txt$ at location x,y color fg,bg without altering global color values
'txt$ may contain control characters without using _controlchr
'use on screen mode 0 screens only
DIM o AS _MEM
DIM AS _OFFSET ts, math_once
o = _MEMIMAGE(_DEST)
w = (_WIDTH(_DEST)) * 2
ts = o.OFFSET + (y - 1) * w + (x - 1) * 2
c = (fg \ 16) * 128 + (fg MOD 16) + bg * 16
FOR cx = 1 TO LEN(txt$)
math_once = ts + (cx - 1) * 2
v = ASC(txt$, cx)
_MEMPUT o, math_once, v AS _UNSIGNED _BYTE
_MEMPUT o, math_once + 1, c AS _UNSIGNED _BYTE
NEXT cx
_MEMFREE o
END SUB
SUB cfprintFAST (x, y, fg, txt$)
'print color text txt$ at location x,y color fg without altering global color values or background colors under txt$
'txt$ may contain control characters without using _controlchr
'this simulates some of the behavior of _printmode _keepbackground
'use on screen mode 0 screens only
DIM o AS _MEM
DIM AS _OFFSET ts, math_once
o = _MEMIMAGE(_DEST)
w = (_WIDTH(_DEST)) * 2
ts = o.OFFSET + ((y - 1) * w + (x - 1) * 2)
ff = fg MOD 16
cc = INT(fg / 16) * 128 + ff
FOR cx = 1 TO LEN(txt$)
math_once = ts + (cx - 1) * 2
v = ASC(txt$, cx)
c1 = _MEMGET(o, math_once + 1, _UNSIGNED _BYTE)
c = cc + (c1 \ 16) * 16
_MEMPUT o, math_once, v AS _UNSIGNED _BYTE
_MEMPUT o, math_once + 1, c AS _UNSIGNED _BYTE
NEXT cx
_MEMFREE o
END SUB
$CHECKING:ON
Unless I screwed something up with how it's supposed to perform (I don't think I did), it seems to be a wee bit faster like this.
Posts: 4,698
Threads: 222
Joined: Apr 2022
Reputation:
322
Interesting how you did checking on/off with subs!
But you left out comparing to standard way with Color + Locate + Print
I am weighing the cost of extra lines of code for subs and ease of typing one line instead of 3 with standard 3 maybe try good ole CLP sub:
Sub CLP(fg, bg, row, col, text$)
color fg, bg
locate row, col
print text$;
end sub
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
|
