QB64 Phoenix Edition
cprint and cfprint text mode routines - Printable Version

+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Utilities (https://qb64phoenix.com/forum/forumdisplay.php?fid=8)
+---- Thread: cprint and cfprint text mode routines (/showthread.php?tid=2024)

Pages: 1 2


cprint and cfprint text mode routines - James D Jarvis - 09-23-2023

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



RE: cprint and cfprint text mode routines - bplus - 09-23-2023

(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.


RE: cprint and cfprint text mode routines - James D Jarvis - 09-23-2023

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]

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



RE: cprint and cfprint text mode routines - SMcNeill - 09-23-2023

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


RE: cprint and cfprint text mode routines - bplus - 09-23-2023

(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.
[Image: 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

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....


RE: cprint and cfprint text mode routines - SMcNeill - 09-23-2023

Change:

v = Asc(Mid$(txt$, cx, 1))

To:

v = ASC(txt$, cx)


RE: cprint and cfprint text mode routines - bplus - 09-23-2023

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

   


RE: cprint and cfprint text mode routines - bplus - 09-23-2023

(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



RE: cprint and cfprint text mode routines - SMcNeill - 09-23-2023

(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.


RE: cprint and cfprint text mode routines - bplus - 09-23-2023

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