MicroFontEditor - Printable Version

Code: (Select All)
Option _Explicit

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

Const TRUE = -1, FALSE = 0

Dim Shared mx, my, m1Hit, m1Rpt, m1Dn, m1End, m2Hit, m2Dn ' for MouseCk

_Title "MicroFontEditor"

Screen _NewImage(1024, 768, 256)

Color 0, 15

Cls



' == MAIN start ==

'  96  (16x6) (iCols, iRows) Characters, each has

'  24   (4x6) (ix, iy) Cells, each has

' 100 (10x10) (iu, iv) Pixels

Const nCols = 16, nRows = 6

Const xHI = 16 * 6, yHI = 6 * 8, uHI = xHI * 10, vHI = yHI * 10

Dim Shared s480 As String * 480, s5 As String * 5, sFont

Dim i, s, iCol, iRow, iu, iv, ix, iy, icolor, iBit



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

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

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

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

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

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

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

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

s480 = sFont

doAllChars

For i = 0 To 127 ' axes labels

  If i < 16 Then Locate 1, 2 + iLerpLH(5, 117, i, 0, 15): Print "x" + Hex$(i);

  If i < 6 Then Locate 1 + iLerpLH(3, 28, i, 0, 5), 1: Print Hex$(i + 2) + "x";

Next i



' -- print static info

Locate 34, 1

Print "    MicroFont V1.0" + Chr$(13)

Print "    Use mouse to invert cell colors."

Print "    Right-click to copy/paste a character"

Print "    ESC to exit"

Do ' ------------- MAIN LOOP ------------------------

  _Limit 300

  MouseCk ' get mouse data

  If iBox(64, 36, "Font (8 Strings) to clipboard") Then doCopyClip

  If iBox(64, 37, "Load internal font") Then dofill 1

  If iBox(64, 38, "Clear characters") Then dofill 0

  If iBox(64, 39, "Random characters") Then dofill 2

  ' ----------- now look at the characters ------------

  If Not isIn(mx, 26, 986) Or Not isIn(my, 26, 506) Then icolor = 99: GoTo Continue1

  iCol = iLerpLH(0, 15, mx, 26, 986) ' 976 = 26+16*6*10; character column

  iRow = iLerpLH(0, 5, my, 26, 506) ' 506 = 26+6*8*10; row

  ix = iLerpLH(0, 5, (mx + 34) Mod 60, 0, 60) ' +34 = -26; cell x

  iy = iLerpLH(0, 7, (my + 54) Mod 80, 0, 80) ' +54 = -36; y

  If iCol > 15 Or iRow > 5 Or ix > 4 Or iy > 6 Then GoTo Continue1 ' is in borders

  If m2Hit Then copyPaste: GoTo Continue1 ' copy/paste dialog

  If m1Dn Then ' if mouse

    If m1Hit Then ' get the inverse color

      iBit = 1 - igetBit(iCol, iRow, ix, iy)

      If iBit Then icolor = 0 Else icolor = 15

    ElseIf icolor = 99 Then

      GoTo Continue1 ' have no color

    End If

    setBit iCol, iRow, ix, iy, iBit

    doCell iCol, iRow, ix, iy, icolor

  End If

  Continue1: ' -- end of character check

  _Display

Loop While InKey$ <> Chr$(27)

System

' == ROUTINES start ==



Sub doAllChars ()

  Dim iCol, iRow, ix, iy, icolor

  For iRow = 0 To 5 ' character

    For iCol = 0 To 15

      For ix = 0 To 4 ' cell

        For iy = 0 To 6

          If igetBit(iCol, iRow, ix, iy) Then icolor = 0 Else icolor = 15

          doCell iCol, iRow, ix, iy, icolor

        Next iy

      Next ix

    Next iCol

  Next iRow

End Sub



Sub doCell (iC, iR, iX, iY, icolor) ' draw rectangle, interior

  Dim iu, iv

  iu = 26 + (iC * 6 + iX) * 10: iv = 26 + (iR * 8 + iY) * 10

  Line (iu, iv)-(iu + 10, iv + 10), 7, B

  Line (iu + 2, iv + 2)-(iu + 10 - 2, iv + 10 - 2), icolor, BF

End Sub



Function igetBit (iC, iR, iX, iY) ' get bit; 0 or 1

  Dim s1 As String * 1, imask, ich

  s1 = Mid$(s480, 1 + (iC + iR * 16) * 5 + iX, 1)

  imask = 2 ^ (6 - iY) ' 0-6: 1,2,4,8,16,32,64

  ich = Asc(s1)

  If (ich And imask) Then igetBit = 1 Else igetBit = 0

End Function



Sub setBit (iC, iR, iX, iY, iBit) ' set bit

  Dim ipos, imask, icho, ich

  ipos = 1 + (iC + iR * 16) * 5 + iX ' position of ch in s480

  imask = 2 ^ (6 - iY) ' 0-6: 1,2,4,8,16,32,64

  icho = Asc(Mid$(s480, ipos, 1)) ' ch from s480

  ich = icho And (255 - imask) ' ch without bit

  If iBit Then ich = ich Or imask ' OR bit

  Mid$(s480, ipos, 1) = Chr$(ich)

End Sub



Sub copyPaste () ' copy/paste dialog

  Dim iC, iR ' column, row

  Play "v10t64l64c"

  iC = iLerpLH(0, 15, mx, 26, 986) ' 976 = 26+16*6*10

  iR = iLerpLH(0, 5, my, 26, 506) ' 506 = 26+6*8*10

  s5 = Mid$(s480, 1 + (iC + iR * 16) * 5, 5) ' one character

  Log "Right-click to paste or ESC to cancel"

  Do ' -- copy/paste dialog

    _Limit 30

    MouseCk

    If m2Hit Then

      iC = iLerpLH(0, 15, mx, 26, 986) ' 976 = 26+16*6*10

      iR = iLerpLH(0, 5, my, 26, 506) ' 506 = 26+6*8*10

      Mid$(s480, 1 + (iC + iR * 16) * 5, 5) = s5 ' paste

      doAllChars

      Exit Do

    End If

    _Display

  Loop Until InKey$ <> ""

  Log ""

End Sub



Function iLerpLH (ivlo, ivhi, x, xlo, xhi) ' linear interp

  Dim i

  i = ivlo + Int((ivhi + 1 - ivlo) * (x - xlo) / (xhi - xlo))

  If i > ivhi Then iLerpLH = ivhi Else iLerpLH = i

End Function



Sub Log (stxt)

  Play "v10t64l64c"

  If stxt = "" Then

    Locate 34, 64: Print Space$(60);

  Else

    Color , 14: Locate 34, 64: Print stxt: Color , 15

  End If

End Sub



Function iBox (iC, iR, sTxt) ' check box

  Dim iu, iv

  iu = iC * 8: iv = iR * 16

  Line (iu + 1, iv - 15)-(iu + 17, iv - 1), 14, BF

  Line (iu + 1, iv - 15)-(iu + 17, iv - 1), 0, B

  Locate iR, iC + 4: Print sTxt;

  If isInXY(mx, my, iu + 1, iv - 15, iu + 17, iv - 1) And m1Hit Then iBox = TRUE

End Function



Sub doCopyClip () ' copy font (8 strings) to clipboard

  Dim i, s: For i = 1 To 480 Step 60

    s = s + "sFont = sFont + " + Chr$(34) + Mid$(s480, i, 60) + Chr$(34) + Chr$(13)

  Next i

  _Clipboard$ = s

  Log "Font copied to clipboard"

End Sub



Sub dofill (n) ' 0:Clear 1:internal 2: random

  Dim i

  Select Case n

    Case 0: s480 = String$(480, &H80)

    Case 1: s480 = sFont ' internal

    Case 2: For i = 1 To 480 ' random

        Mid$(s480, i, 1) = Chr$(128 + (127 * Rnd) And (127 * Rnd)) ' P(r*r) = .25

      Next i

  End Select

  doAllChars

End Sub



Function isInXY (x, y, xlo, ylo, xhi, yhi)

  If x >= xlo And x <= xhi And y >= ylo And y <= yhi Then isInXY = TRUE

End Function



Function isIn (x, a, b) ' ck between

  If x >= a And x <= b Then isIn = TRUE

End Function



Function iMsecs () ' milliseconds since midnight UTC

  iMsecs = Int(Timer(.001) * 1000 + .5)

End Function



' -- need Dim Shared mx,my,m1Hit,m1Rpt,m1Dn,m1End, m2Hit

Sub MouseCk () ' get mouse info

  Static m1Prev, m2Prev, m1Time, m2Time ' for getting DownEdge (Hit) and Repeating

  Dim mIn, isw1

  m1Hit = 0: m1Rpt = 0: m1Dn = 0: m1End = 0: m2Hit = 0: m2Dn = 0

  Do ' go thru all previous mouse data

    mIn = _MouseInput

    If mIn = 0 Then Exit Do

    mx = _MouseX: my = _MouseY

  Loop

  If _MouseButton(1) Then ' Btn 1 down

    m1Dn = TRUE

    If Not m1Prev Then ' start of downtime

      m1Hit = TRUE: m1Time = iMsecs + 250 ' delay 1/4 sec

    Else ' has been down, ck for repeat

      If iMsecs > m1Time Then m1Rpt = TRUE: m1Time = iMsecs + 50 ' repeat 20/sec

    End If

    m1Prev = TRUE ' for next time

  Else ' Btn 1 up

    If m1Prev Then m1End = TRUE ' end of downtime

    m1Prev = FALSE ' for next time

  End If

  If _MouseButton(2) Then ' Btn 2 down

    m2Dn = TRUE

    If Not m2Prev Then ' start of downtime

      m2Hit = TRUE

    Else

      m2Prev = FALSE ' for next time

    End If

    m2Prev = TRUE

  Else

    m2Prev = FALSE

  End If

End Sub