MicroFont, a 5x7 dot-matrix font

Code: (Select All)
_Title "MicroFont 1.0"

Option _Explicit

DefSng A-Z: DefLng I-N: DefStr S

Randomize Timer

Screen _NewImage(1024, 768, 256)

Color 0, 15

Cls

' == MAIN start ==

Dim Shared void, sWord, sWords(100), xy(100, 4), nWords

Dim i, nloop, velocity

Data Twas,brillig,and,the,slithy,toves,/

Data Did,gyre,and,gimble,in,the,wabe,/

Data All,mimsy,were,the,borogoves,/

Data And,the,mome,raths,outgrabe.,~



MicroFont "Demo of MicroFont", 440, 6 ' == DRAWS THE TITLE ==

Circle (440, 6), 2 ' shows the ix, iy used above

loadWords ' load data into array



Do ' == Main loop ==

  _Limit 60

  nloop = nloop + 1

  If nloop = 180 Then velocity = .01 '

  If nloop > 180 Then velocity = velocity * 1.01

  If velocity > 1 Then velocity = 1

  For i = 1 To nWords ' move all words

    xy(i, 1) = xy(i, 1) + xy(i, 3) * velocity

    xy(i, 2) = xy(i, 2) + xy(i, 4) * velocity

    MicroFont sWords(i), xy(i, 1), xy(i, 2) ' draws individual words

    If xy(i, 1) < 0 Then xy(i, 3) = Abs(xy(i, 3)) ' bounce

    If xy(i, 2) < 6 Then xy(i, 4) = Abs(xy(i, 4))

    If xy(i, 1) > 1000 Then xy(i, 3) = -Abs(xy(i, 3))

    If xy(i, 2) > 767 Then xy(i, 4) = -Abs(xy(i, 4))

  Next i

Loop While InKey$ = ""

System



Sub loadWords ()

  Dim ang, ix, iy, sword: ix = 400: iy = 300

  Do

    Read sword

    If sword = "~" Then Exit Do ' ck EOF

    If sword = "/" Then ix = 400: iy = iy + 12: GoTo continue1 ' ck EOL

    MicroFont sword, ix, iy ' == DRAWS ONE WORD ==

    nWords = nWords + 1 ' into array for moving

    sWords(nWords) = sword

    xy(nWords, 1) = ix

    xy(nWords, 2) = iy

    ang = Rnd * 6.2832

    xy(nWords, 3) = Cos(ang)

    xy(nWords, 4) = Sin(ang)

    ix = ix + Len(sword) * 6 + 5

    continue1:

  Loop

End Sub



DefStr S: DefLng I-N ' This is needed

Sub MicroFont (sstr, ixx0, iyy0) ' ==== THIS IS THE MicroFont ROUTINE ====

  ' -- prints string sstr at position ixx0 and iy0 --

  Static sFont, s96

  If sFont = "" Then ' load once only

    sFont = sFont + "€€€€€€€û€€€à€à€”¾”¾”ªÿª„¢„ˆ¢†¹Í²…€€ð€€€œ¢Á€€Á¢œ€ˆªœªˆˆˆ¾ˆˆ"

    sFont = sFont + "€‡†€€ˆˆˆˆˆ€ƒƒ€€‚„ˆ ¾ÅÉÑ¾€¡ÿ¡ÃÅÉ±¢ÉÉÉ¶Œ”¤ÿ„úÉÉÉÆ¾ÉÉÉ¦ÃÄÈÐà"

    sFont = sFont + "¶ÉÉÉ¶²ÉÉÉ¾€€¶€€€¶€€€ˆ”¢€€”””€€¢”ˆ€ ÀÅÈ°¾ÁÝÅ¼¿ÈÈÈ¿ÿÉÉÉ¶¾ÁÁÁ¢"

    sFont = sFont + "ÿÁÁÁ¾ÿÉÉÉÁÿÈÈÈÀ¾ÁÁÅ¦ÿˆˆˆÿ€ÁÿÁ€‚ÁþÀÿˆ”¢Áÿÿ  ÿÿ ˜„ÿ¾ÁÁÁ¾"

    sFont = sFont + "ÿÄÄÄ¸¸ÄÄÄÿÿÈÌÊ±²ÉÉÉ¦ÀÀÿÀÀþþü‚‚üþ†þÁ¶ˆ¶ÁÀ°°ÀÃÅÉÑá€€ÿÁ€"

    sFont = sFont + " ˆ„‚€Áÿ€€„ˆˆ„€Àà €‚•••þ‘‘‘ŽŽ‘‘‘‘Ž‘‘‘þŽ•••Œ€ˆ¿È ˆ•••Ž"

    sFont = sFont + "ÿ€€Þ€€Þ€€ÿ„Š‘‘€€þŸŸŸˆŸŽ‘‘‘Ž’’’ŒŒ’’’Ÿˆˆˆ•••‚"

    sFont = sFont + "€þ‘ž‚Ÿœ‚‚œž†ž‘Š„Š‘™……‚œ‘“•™‘€ˆ¶Á€€€÷€€€Á¶ˆ€ˆˆ„ˆˆ„ˆ"

    s96 = s96 + " !##$%&'()*+,-./0123456789:;<=>?"

    s96 = s96 + "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_"

    s96 = s96 + "`abcdefghijklmnopqrstuvwxyz{|}~"

    Mid$(s96, 3, 1) = Chr$(34) ' fix quote "

  End If ' end of once only

  Dim iposStr, ipos96, ipos480, ix0, iy0, ix, iy, imask, ich

  ix0 = ixx0 - 1: iy0 = iyy0 + 1 ' byValue

  For iposStr = 1 To Len(sstr) ' one character at a time

    ipos96 = InStr(1, s96, Mid$(sstr, iposStr, 1))

    If ipos96 = 0 Then ipos96 = 4 ' invalid character -> #

    ipos480 = (ipos96 - 1) * 5 ' index to sFont

    For ix = 0 To 6: imask = 1 ' OxxxxxO 5 columns in character

      If 1 <= ix And ix <= 5 Then ich = Asc(Mid$(sFont, 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

          PSet (ix0 + ix, iy0 - iy), 15 ' BG

        Else ' choose FG or BG

          If ich And imask Then ' ck bit

            PSet (ix0 + ix, iy0 - iy), 0 ' FG

          Else

            PSet (ix0 + ix, iy0 - iy), 15 ' BG

          End If

          imask = imask + imask ' next bit in column

        End If

      Next iy

    Next ix

    ix0 = ix0 + 6 ' next char output

  Next iposStr

  ' could modify ix here

End Sub