QB64 Phoenix Edition
BLOCKMODE demo - Printable Version

+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: BLOCKMODE demo (/showthread.php?tid=556)

BLOCKMODE demo - James D Jarvis - 06-15-2022

In a world where high resolution graphics dominate the microcomputing industry and hobby programming it only seemed fitting to develop a display mode that was certainly not high-res. 
Blockmode uses 4 traditional character codes to create graphics along with 256 colors in a massive display of low-res splendor of 160 x 98(ish) boxels. With block printing that allows 26 characters per line of text on 12 whole lines !
It's a marvel of mixed mode graphics that I couldn't think of a better name for.

I'd like to thank dcromley for developing and sharing microfont, without his contribution you might be seeing less block letters in the demo.

Code: (Select All)
'blockmodedemo
'lower-res graphics demo fun
'by James D. Jarvis
' uses microfont by dcromley
Dim Shared drawspace&, s&
drawspace& = _NewImage(161, 100, 256)
s& = _NewImage(1280, 1600, 256)
Screen s&
_FullScreen
_Scrolllock On
Randomize Timer
Dim Shared blk$(0 To 3), BSCR_klr, BSCR_bkg, Bgrid(160, 100, 3)
Dim Shared bfont$
Dim Shared b96$
blk$(0) = " ": blk$(1) = Chr$(176): blk$(2) = Chr$(177): blk$(3) = Chr$(178)
BSCR_klr = 15: BSCR_bkg = 0
Const bgblk = 1, bgklr = 2, bgbkg = 8
bstart
For x = 1 To 160
    For y = 1 To 98
        If y Mod 2 > 0 Then
            If x Mod 2 > 0 Then
                BSET x, y, 2, 3, 0
            Else
                BSET x, y, 1, 3, 9
            End If
        Else
            If x Mod 2 > 0 Then
                BSET x, y, 1, 3, 9
            Else
                BSET x, y, 2, 3, 0
            End If

        End If
    Next y
Next x
drawblocks 1, 160, 1, 98

bat 1, 1, "BLOCKMODE"
bat 1, 2, "160 x 98 bloxels"
bat 1, 3, "Block Print 26 c by 12 r "
bat 1, 4, "abcdefghijklmnopqrstuvwxyz"
bat 1, 5, "Can use draw commands"
blat 80, 50, " ", 15, 0
bdraw "r5d7l5u7"
bdraw "br7c11r5d1c7l5d1c8r5"
bcircle 50, 60, 9, 5
barc 50, 60, 9, 12, 0, 360
bat 1, 11, "press any key"

Do
    _Limit 60
    A$ = InKey$
Loop Until A$ <> ""


'oh yeah ...
Cls
bat 1, 1, "To Boldy Block"
_Delay 0.3
bat 1, 2, "Where No Block"
_Delay 0.3
bat 1, 3, "Has Blocked Before"
_Delay 0.3
For x = 1 To 30
    _Limit 10
    blat 1, 99, " ", 15, 0
Next x
_Dest drawspace&
Cls
_Dest s&
For px = 1 To 22
    _Limit 20
    _Dest drawspace&: Cls
    _Dest s&: Cls
    drawplayership px, 50
    _Display
Next px
For kx = 160 To 100 Step -1
    _Limit 20
    _Dest drawspace&: Cls
    _Dest s&: Cls
    drawplayership px, 50

    drawkremulan kx, 60, 180
    If kx < 140 Then
        drawkremulan kx + 20, 70, 180
    End If
    If kx < 120 Then
        drawkremulan kx + 40, 50, 180
    End If
    _Display
Next kx
bat 1, 1, "This Is Capt. Peek"
_Delay 0.5
_Display
bat 1, 2, " We"
_Delay 0.6
_Display
bat 5, 2, "Come"
_Delay 0.7
_Display
bat 10, 2, "In"
_Delay 0.8
_Display
bat 13, 4, "Peace"
_Display
_Delay 2

_Dest drawspace&: Cls
_Dest s&: Cls
drawplayership px, 50
drawkremulan kx, 60, 180
drawkremulan kx + 20, 70, 180
drawkremulan kx + 40, 50, 180
_Display

BSCR_klr = 6: BSCR_bkg = 0
bat 5, 2, "More FEDERATION LIES !"
_Display
_Delay 0.5
bat 5, 3, "The Real Question is "
_Display
_Delay 0.2
bat 6, 4, "To Block,": bat 7, 5, " Or Not To Block!"
_Display
_Delay 0.4

BSCR_klr = 15: BSCR_bkg = 0
bat 1, 11, "press any key..."
_Display
Do
    A$ = InKey$
Loop Until A$ <> ""
_Dest drawspace&: Cls
_Dest s&: Cls
drawplayership px, 50
drawkremulan kx, 60, 180
drawkremulan kx + 20, 70, 180
drawkremulan kx + 40, 50, 180
_Display
kbx1 = kx - 4: kby1 = 60
kbx2 = kx + 16: kby2 = 70
kbx3 = kx + 36: kby3 = 50
fbx1 = px + 4: fby1 = 48
fbx2 = px + 4: fby2 = 52
For n = 1 To 100
    _Limit 20
    _Dest drawspace&: Cls
    _Dest s&: Cls
    If n > 60 Then px = px + 1
    If n < 90 Then drawkremulan kx, 60, 180
    drawkremulan kx + 20, 70, 180
    If n < 95 Then drawkremulan kx + 40, 50, 180
    drawplayership px, 50
    If n < 20 Then
        ' blat kbx1 - n, 6, blk$(1), 4, 8
        dburst kbx1 - n * 3, kby1 - (n * .8), 2, 4
    End If
    If n > 23 And n < 44 Then
        ' blat kbx1 - n, 6, blk$(1), 4, 8

        dburst fbx1 + (n - 23) * 3, fby1 + n / 8, 2, 11
    End If
    If n > 25 And n < 46 Then
        ' blat kbx1 - n, 6, blk$(1), 4, 8
        dburst fbx2 + (n - 25) * 3, fby2 + n / 10, 2, 11
    End If
    If n > 15 And n < 30 Then
        dburst kbx2 - n * 3, kby2 - (n * .8), 2, 4
    End If
    If n > 12 And n < 27 Then
        dburst kbx3 - n * 3, kby3 + (n * .8), 2, 4
    End If
    If n > 25 And n < 45 Then
        dburst kbx3 - n * 3, kby3 + (n * .8), 2, 4
    End If
    If n > 52 And n < 90 Then
        _Dest drawspace&
        Select Case Int(Rnd * 8)
            Case 0:
                Line (px + 1, fby1)-(kbx1, kby1), 11
                Line (px + 1, fby2)-(kbx3, kby3), 11
            Case 1:
                Line (px + 1, fby1)-(kbx1, kby1), 11
                Line (px + 1, fby2)-(kbx2, kby2), 11
            Case 2:
                Line (px + 1, fby2)-(kbx3, kby3), 11
            Case 3:
                Line (px + 1, fby2)-(kbx2, kby2), 11
            Case 4:
                Line (px + 1, fby1)-(kbx1, kby1), 3
            Case 5:
                Line (px + 1, fby1)-(kbx1, kby1), 3
                Line (px + 1, fby2)-(kbx3, kby3), 11
            Case 6:
                Line (px + 1, fby2)-(kbx3, kby3), 3
                Line (px + 1, fby2)-(kbx2, kby2), 11
                Line (px + 1, fby1)-(kbx1, kby1), 11
            Case 7:
                Line (px + 1, fby1)-(kbx1, kby1), 11
                Line (px + 1, fby2)-(kbx2, kby2), 3
        End Select
        _Source drawspace&
        For x = 1 To 160
            For y = 1 To 98
                b = Point(x, y)
                If b > 0 Then
                    _Dest s&
                    blat x, y, blk$(3), b, b
                End If
            Next y
        Next x
        If n > 65 And n < 90 Then
            dburst kbx1, kby1, Int(Rnd * 4) + 2, 12
            If Int(Rnd * 9) < 7 Then dburst kbx1 + Int(Rnd * 4) + 2, kby1, Int(Rnd * 5), 14
            If Int(Rnd * 9) < 7 Then dburst kbx1 + Int(Rnd * 6) + 2, kby1, Int(Rnd * 4), 4
        End If
        If n > 69 And n < 95 Then
            dburst kbx2, kby2, Int(Rnd * 4) + 2, 12
            If Int(Rnd * 9) < 7 And n < 93 Then dburst kbx2 + Int(Rnd * 4) + 2, kby2, Int(Rnd * 5), 14
            If Int(Rnd * 9) < 7 Then dburst kbx2 + Int(Rnd * 6) + 2, kby2, Int(Rnd * 4), 4
        End If
        If n > 70 Then
            dburst kbx3, kby3, Int(Rnd * 4) + 2, 12
            If Int(Rnd * 9) < 7 And n < 98 Then dburst kbx3 + Int(Rnd * 4) + 2, kby3, Int(Rnd * 5), 14
            If Int(Rnd * 9) < 7 Then dburst kbx3 + Int(Rnd * 6) + 2, kby3, Int(Rnd * 4), 4
        End If
        If n > 80 Then kx1 = kx1 + 2
        If n > 90 Then kx3 = kb3 + 1

        _Dest s&

    End If
    _Display
Next n
For n = 1 To 30
    _Limit 20
    _Dest drawspace&: Cls
    _Dest s&: Cls
    px = px + 2
    drawplayership px, 50
    If k < 25 Then
        dburst kbx2, kby2, Int(Rnd * n) + 2, 12
        If n < 23 Then drawkremulan kx + 20, 70, 180
        _Dest drawspace&
        Select Case Int(Rnd * 8)
            Case 0:
                Line (px + 1, fby1)-(kbx2, kby2), 3
                Line (px + 1, fby2)-(kbx2, kby2), 11
            Case 1:
                Line (px + 1, fby1)-(kbx2, kby2), 11
                Line (px + 1, fby2)-(kbx2, kby2), 3
            Case 2:
                Line (px + 1, fby1)-(kbx2, kby2), 11
            Case 3:
                Line (px + 1, fby2)-(kbx2, kby2), 3
        End Select
        _Source drawspace&
        For x = 1 To 160
            For y = 1 To 98
                b = Point(x, y)
                If b > 0 Then
                    _Dest s&
                    blat x, y, blk$(3), b, b
                End If
            Next y
        Next x
    End If

    _Display
Next n
For n = 1 To 30
    _Limit 20
    _Dest drawspace&: Cls
    _Dest s&: Cls
    bat 1, 1, "It would seem that the"
    bat 2, 2, " Kremulans decided to .."
    If n > 15 Then bat 3, 3, " leave in PIECES"
    px = px + 1
    drawplayership px, 50
    _Display
Next n
'the blockmode subs
bat 1, 11, "press any key"
_Display
A$ = ""
Do
    _Limit 60
    A$ = InKey$
Loop Until A$ <> ""


System

Sub bstart
    For r = 1 To 30
        _Limit 60
        For b = 1 To 50
            blat Int(Rnd * 160) + 1, Int(Rnd * 98) + 1, blk$(Int(Rnd * 4)), Int(Rnd * 16), Int(Rnd * 16)
        Next b
    Next r
    _Delay 0.2
    Cls
    For r = 1 To 50
        For c = 1 To 151
            Bgrid(c, r, 1) = 0
            Bgrid(c, r, 2) = BSCR_klr
            Bgrid(c, r, 2) = BSCR_bkg
        Next c
    Next r
    bfont$ = bfont$ + "€€€€€€€û€€€à€à€”¾”¾”ªÿª„¢„ˆ¢†¹Í²…€€ð€€€œ¢Á€€Á¢œ€ˆªœªˆˆˆ¾ˆˆ"
    bfont$ = bfont$ + "€‡†€€ˆˆˆˆˆ€ƒƒ€€‚„ˆ ¾ÅÉѾ€¡ÿ¡ÃÅɱ¢ÉÉɶŒ”¤ÿ„úÉÉÉƾÉÉɦÃÄÈÐà"
    bfont$ = bfont$ + "¶ÉÉɶ²ÉÉɾ€€¶€€€¶€€€ˆ”¢€€”””€€¢”ˆ€ ÀÅÈ°¾ÁÝż¿ÈÈÈ¿ÿÉÉɶ¾ÁÁÁ¢"
    bfont$ = bfont$ + "ÿÁÁÁ¾ÿÉÉÉÁÿÈÈÈÀ¾ÁÁŦÿˆˆˆÿ€ÁÿÁ€‚ÁþÀÿˆ”¢Áÿÿ  ÿÿ ˜„ÿ¾ÁÁÁ¾"
    bfont$ = bfont$ + "ÿÄÄĸ¸ÄÄÄÿÿÈÌʱ²ÉÉɦÀÀÿÀÀþþü‚‚üþ†þÁ¶ˆ¶ÁÀ°°ÀÃÅÉÑကÿÁ€"
    bfont$ = bfont$ + " ˆ„‚€Áÿ€€„ˆˆ„€Àà €‚•••þ‘‘‘ŽŽ‘‘‘‘Ž‘‘‘þŽ•••Œ€ˆ¿È ˆ•••Ž"
    bfont$ = bfont$ + "ÿ€€Þ€€Þ€€ÿ„Š‘‘€€þŸŸŸˆŸŽ‘‘‘Ž’’’ŒŒ’’’Ÿˆˆˆ•••‚"
    bfont$ = bfont$ + "€þ‘ž‚Ÿœ‚‚œž†ž‘Š„Š“™……‚œ‘“•™‘€ˆ¶Á€€€÷€€€Á¶ˆ€ˆˆ„ˆˆ„ˆ"

    b96$ = b96$ + " !" + Chr$(34) + "#$%&'()*+,-./0123456789:;<=>?"
    b96$ = b96$ + "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_"
    b96$ = b96$ + "`abcdefghijklmnopqrstuvwxyz{|}~"

End Sub
Sub bat (bcol, brow, B$)
    'print block charcters into fixed spots)
    bb = 0: br = brow
    For bc = 1 To Len(B$)
        bb = bb + 1
        If bb = 27 Then
            bb = 1
            br = br + 1
        End If
        bchar Mid$(B$, bc, 1), (bcol + bb) * 6 - 11, (br * 8) - 7
    Next bc
End Sub

Sub blat (bcol, brow, B$, Bklr, Bbkg)
    'color print specific blocks
    Color Bklr, Bbkg
    Locate brow, bcol
    Print B$
    Color BSCR_klr, BSCR_bkg
End Sub

Sub BSET (bcol, brow, BK, Bklr, Bbkg)
    'sets characters and colors on the BGRID
    Bgrid(bcol, brow, 1) = BK
    Bgrid(bcol, brow, 2) = Bklr
    Bgrid(bcol, brow, 3) = Bbkg
End Sub

Sub drawblocks (bc1, bc2, br1, br2)
    'show the bgrid
    'drawing after row 98 will scroll the screen...ooops
    For bc = bc1 To bc2
        For br = br1 To br2
            blat bc, br, blk$(Bgrid(bc, br, bgblk)), Bgrid(bc, br, bgklr), Bgrid(bc, br, bbkg)
        Next br
    Next bc
End Sub


Sub bchar (bstr$, bx, by) ' ==== THIS IS a modified MicroFont ROUTINE ====
    ' -- prints string bstr at position ixx0 and iy0 --
    ixx0 = bx
    iyy0 = by + 8

    Dim ipobstr, ipob96, ipos480, ix0, iy0, ix, iy, imask, ich
    ix0 = ixx0 - 1: iy0 = iyy0 + 1 ' byValue
    For ipobstr = 1 To Len(bstr$) ' one character at a time
        ipob96 = InStr(1, b96$, Mid$(bstr$, ipobstr, 1))
        If ipob96 = 0 Then ipob96 = 4 ' invalid character -> #
        ipos480 = (ipob96 - 1) * 5 ' index to bfont$
        For ix = 0 To 6: imask = 1 ' OxxxxxO 5 columns in character
            If 1 <= ix And ix <= 5 Then ich = Asc(Mid$(bfont$, ipos480 + ix, 1))
            For iy = 0 To 8 ' OxxxxxxxO 7 rows in character
                If ix < 1 Or ix > 5 Or iy < 1 Or iy > 7 Then
                    ' blat ix0 + ix, iy0 - iy, blk$(0), BSCR_klr, BSCR_bkg
                Else ' choose FG or BG
                    If ich And imask Then ' ck bit
                        blat ix0 + ix, iy0 - iy, blk$(3), BSCR_klr, BSCR_klr
                    Else
                        ' blat ix0 + ix, iy0 - iy, blk$(0), BSCR_klr, BSCR_bkg
                    End If
                    imask = imask + imask ' next bit in column
                End If
            Next iy
        Next ix
        ix0 = ix0 + 6 ' next char output
    Next ipobstr
    ' could modify ix here
End Sub
Sub bdraw (BD$)
    _Dest drawspace&
    If LCase$(BD$) = "CLR" Then
        Cls
        BD$ = ""
    Else
        Draw BD$
    End If
    _Source drawspace&
    For x = 1 To 160

        For y = 1 To 98
            b = Point(x, y)
            If b > 0 Then
                _Dest s&
                blat x, y, blk$(3), b, b
            End If
        Next y
    Next x
End Sub
Sub bcircle (xx, yy, r, klr)
    'draw a circle
    _Dest drawspace&
    PSet (xx, yy), 0
    Draw "c" + Str$(klr)
    For d = 0 To 360 Step 1
        Draw "ta " + Str$(d) + " r" + Str$(r) + " bl" + Str$(r)
    Next d
    _Source drawspace&
    For x = 1 To 160

        For y = 1 To 98
            b = Point(x, y)
            If b > 0 Then
                _Dest s&
                blat x, y, blk$(3), b, b
            End If
        Next y
    Next x
End Sub
Sub barc (xx, yy, r, klr, arc1, arc2)
    'draws an arc, will draw an unfilled circle if the arc goes from 0 to 360
    _Dest drawspace&
    t = Point(xx, yy)
    PSet (xx, yy), t
    Draw "c" + Str$(klr)
    For d = arc1 To arc2 Step 1
        Draw "ta " + Str$(d) + " br" + Str$(r - 1) + "r  bl" + Str$(r)
    Next d
    _Source drawspace&
    For x = 1 To 160
        For y = 1 To 98
            b = Point(x, y)
            If b > 0 Then
                _Dest s&
                blat x, y, blk$(3), b, b
            End If
        Next y
    Next x
End Sub

'these subs are used in the blocktrek portion of the demo
' showing how even low-res graphics can be fun
Sub drawplayership (xx, yy)
    _Dest drawspace&
    PSet (xx, yy), 0
    Color 15
    Circle (xx, yy), 5, 15
    Draw " bm -10,0 r10 bm -10,-4 d8 l3 br3 bu8 l3"
    sc = 10
    If shieldstr < shieldmax * .8 Then sc = 2
    If shieldstr < shieldmax * .6 Then sc = 14
    If shieldstr < shieldmax * .4 Then sc = 12
    If shieldstr < shieldmax * .2 Then sc = 4
    If shieldstr > 0 Then Circle (xx, yy), 20, sc, 0, (2 * _Pi) * (shieldstr / shieldmax)
    Draw "ta0"
    _Source drawspace&
    For x = 1 To 160
        For y = 1 To 98
            b = Point(x, y)
            If b > 0 Then
                _Dest s&
                blat x, y, blk$(3), b, b
            End If
        Next y
    Next x

End Sub
Sub drawkremulan (xx, yy, aa)
    _Dest drawspace&
    PSet (xx, yy), 0
    kk = 6
    Color kk
    Circle (xx, yy + 2), 2, kk
    Draw "ta" + Str$(aa) + "r2l1u3d6u3l10 e3 l5 r5 g3 f3 l5 "
    sc = 10
    If kshieldstr < kshieldmax * .8 Then sc = 2
    If kshieldstr < kshieldmax * .6 Then sc = 14
    If kshieldstr < kshieldmax * .4 Then sc = 12
    If kshieldstr < kshieldmax * .2 Then sc = 4

    If kshieldstr > 0 Then Circle (xx, yy), 20, sc, 0, (2 * _Pi) * (kshieldstr / kshieldmax)
    Draw "ta0"
    _Source drawspace&
    For x = 1 To 160
        For y = 1 To 98
            b = Point(x, y)
            If b > 0 Then
                _Dest s&
                blat x, y, blk$(3), b, b
            End If
        Next y
    Next x

End Sub
Sub dburst (xx, yy, r, klr)
    _Dest drawspace&
    PSet (xx, yy), klr
    For d = 0 To 360 Step (1 + Rnd * 10)
        rv = Int(r \ 1.9 + Rnd * (r / 2))
        Draw "ta " + Str$(d) + "c" + Str$(klr) + " r" + Str$(rv) + " bl" + Str$(rv)
    Next d
    _Source drawspace&
    For x = 1 To 160
        For y = 1 To 98
            b = Point(x, y)
            If b > 0 Then
                _Dest s&
                blat x, y, blk$(3), b, b
            End If
        Next y
    Next x

End Sub


RE: BLOCKMODE demo - bplus - 06-15-2022

I think someone is having fun! LOL

Reminds me of the movies it takes days to shoot a 45 sec section of film. Should I ask how long for 528 LOC (Lines of Code)?

RE: BLOCKMODE demo - James D Jarvis - 06-15-2022

(06-15-2022, 09:10 PM)bplus Wrote: I think someone is having fun! LOL

Reminds me of the movies it takes days to shoot a 45 sec section of film. Should I ask how long for 528 LOC (Lines of Code)?

I'm definitely having fun.  It's not all strictly speaking original code, some of it is borrowed, some is old, most of it was still thrown together today.  Maybe 4  (could be 5) hours of "work" scattered throughout the day.    I started doing it as plain old text mode and went a little crazy.   I don't think  I got the "CLR" command to work in the Bdraw sub.

RE: BLOCKMODE demo - dcromley - 06-17-2022

Thanks for the credit (microfont). I hardly recognize the code! Smile Good job.