MicroFontEditor

[dcromley]

MicroFontEditor, to change MicroFont.

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