DIM TextFile AS QFileStream
DIM VFontPointer(255, 3) AS INTEGER
' VFontPointer(nnn,1)  is beginning of a letter in array
' VFontPointer(nnn,2)  is end of a letter in array
' VFontPointer(nnn,3)  how much points must be skipped after letter drawing
'                     (field ADVANCE: in font file)
DIM  VFontData(2500, 4) AS INTEGER
' VFontData(nnn,1) -  x    VFontData(nnn,2) - y
' VFontData(nnn,3) -  x1    VFontData(nnn,4) - y1
DIM VFontCOS(360) AS SINGLE
' Look up  table for cosine
DIM  VFontSIN(360) AS SINGLE
' Look up  table for sinus

Declare FUNCTION RetSymbol (nnn, aa$)  as string
Declare SUB InitVFont (DataFile$)
Declare SUB VPrintAng (xx, yy, text$, clr, xf, yf, angle)


' *****************************************************************
' This is test program
Declare SUB DrawScr
InitVFont ("rus866.vft")
create form as QForm
    Center
    Width = 650
    Height = 490
    create ScrArea as QCanvas
      Top = 5
      Left = 5
      Width = 630
      Height = 450     
      OnPaint = DrawScr   
    end create
end create    
form.ShowModal

sub DrawScr
   VPrintAng 5, 10, "_,./\()0123456789+-? ", &HAD0000, 2, 2, 350
   VPrintAng 200, 45, "qwertyuiop", &H0000AD, 2, 2, 20
   VPrintAng 320, 10, "asdfghjkl", &HFFFFFF, 2, 2, 340
   VPrintAng 430, 45, "zxcvbnm", &H00FF00, 2, 2, 20
   
   VPrintAng 5, 100, "it can be stretched independently :", &H000000, 1.5, 2, 0
   
   VPrintAng 300, 90, "horizontally", &H000000, 5,1.5, 0
   VPrintAng 300, 150, "or vertically", &H000000, 2,10, 0

  ccl = 1
  xfactor = 0.1
  yfactor = 0.1
  FOR it = 0 TO 360 STEP 15
   ttt = it
   xfactor = xfactor + 0.1
   yfactor = yfactor + 0.1
   VPrintAng 200, 250, "it can be printed 360 degrees", &H4600FF, xfactor, yfactor, ttt
   ccl = ccl + 1
   IF ccl > 15 THEN
    ccl = 1
   END IF
  NEXT
END SUB

' Demo end
'***************************************************************************


SUB InitVFont (DataFile$)
LinePointer = 1
CurrentCode = 0
IF FILEEXISTS(DataFile$) = 0  THEN
  Showmessage "Cannot find font file "+DataFile$+_
                      "  Program will be closed." 
   Application.Terminate
END IF
 TextFile.Open (DataFile$, fmOpenRead)
DO
 aa$ = TextFile.ReadLine
 aa$ = LTRIM$(RTRIM$(aa$))
 IF INSTR(aa$, "'") THEN
  '  comment sign found
  nnn = INSTR(aa$, "'")
  aa$ = RTRIM$(LEFT$(aa$, nnn - 1))
 END IF
 IF LEN(aa$) <> 0 THEN
   IF INSTR(aa$, "GRIDHEIGHT:") <> 0 THEN
     '  Average height of letters in this font
      nnn = INSTR(aa$, ":")
      VFontGridHeight = VAL(LTRIM$(RIGHT$(aa$, LEN(aa$) - nnn)))
   END IF
   IF INSTR(aa$, "GRIDWIDTH:") <> 0 THEN
     ' Average width of letters in this font
      nnn = INSTR(aa$, ":")
      VFontGridWidth = VAL(LTRIM$(RIGHT$(aa$, LEN(aa$) - nnn)))
   END IF
   IF INSTR(aa$, "TITLE:") <> 0 THEN
     ' Letter title - not used
     ' 
   END IF
   IF INSTR(aa$, "CODE:") THEN
    '  determine letter code , store it's beginning in  VFontData
    nnn = INSTR(aa$, ":")
    CurrentCode = VAL(LTRIM$(RIGHT$(aa$, LEN(aa$) - nnn)))
    VFontPointer(CurrentCode, 1) = LinePointer
   END IF
   IF INSTR(aa$, "ADVANCE:") <> 0 THEN
     ' End of letter description 
    nnn = INSTR(aa$, ":")
    VFontPointer(CurrentCode, 2) = LinePointer - 1
    VFontPointer(CurrentCode, 3) = VAL(LTRIM$(RIGHT$(aa$, LEN(aa$) - nnn)))
   END IF
   IF LEFT$(aa$, 1) = "L" THEN
    aa$ = aa$ + ","
    aa$ = LTRIM$(RIGHT$(aa$, LEN(aa$) - 1))
    ' There MUST be 4 values in line ( x,y,x1,y1 )
     VFontData(LinePointer, 1) = VAL(RetSymbol(1, aa$))
     VFontData(LinePointer, 2) = VAL(RetSymbol(2, aa$))
     VFontData(LinePointer, 3) = VAL(RetSymbol(3, aa$))
     VFontData(LinePointer, 4) = VAL(RetSymbol(4, aa$))
     LinePointer = LinePointer + 1
   END IF
   IF LEFT$(aa$, 1) = "B" THEN
    ' box is converted into  4 lines
    aa$ = aa$ + ","
    aa$ = LTRIM$(RIGHT$(aa$, LEN(aa$) - 1))
     VFontData(LinePointer, 1) = VAL(RetSymbol(1, aa$))
     VFontData(LinePointer, 2) = VAL(RetSymbol(2, aa$))
     VFontData(LinePointer, 3) = VAL(RetSymbol(1, aa$))
     VFontData(LinePointer, 4) = VAL(RetSymbol(4, aa$))
     LinePointer = LinePointer + 1
     VFontData(LinePointer, 1) = VAL(RetSymbol(1, aa$))
     VFontData(LinePointer, 2) = VAL(RetSymbol(4, aa$))
     VFontData(LinePointer, 3) = VAL(RetSymbol(3, aa$))
     VFontData(LinePointer, 4) = VAL(RetSymbol(4, aa$))
     LinePointer = LinePointer + 1
     VFontData(LinePointer, 1) = VAL(RetSymbol(3, aa$))
     VFontData(LinePointer, 2) = VAL(RetSymbol(4, aa$))
     VFontData(LinePointer, 3) = VAL(RetSymbol(3, aa$))
     VFontData(LinePointer, 4) = VAL(RetSymbol(2, aa$))
     LinePointer = LinePointer + 1
     VFontData(LinePointer, 1) = VAL(RetSymbol(3, aa$))
     VFontData(LinePointer, 2) = VAL(RetSymbol(2, aa$))
     VFontData(LinePointer, 3) = VAL(RetSymbol(1, aa$))
     VFontData(LinePointer, 4) = VAL(RetSymbol(2, aa$))
     LinePointer = LinePointer + 1
   END IF
   IF INSTR(aa$, "REFERENCE:") <> 0 THEN
     ' appearence is the same with the other letter  (S with 5 for example)
     ' here we make reference to  already loaded symbol
    nnn = INSTR(aa$, ":")
    RefCode = VAL(LTRIM$(RIGHT$(aa$, LEN(aa$) - nnn)))
    VFontPointer(CurrentCode, 1) = VFontPointer(RefCode, 1)
    VFontPointer(CurrentCode, 2) = VFontPointer(RefCode, 2)
    VFontPointer(CurrentCode, 3) = VFontPointer(RefCode, 3)
  END IF
 END IF
LOOP UNTIL TextFile.Position >= TextFile.Size
TextFile.Close
IF VFontGridHeight = 0 then
  ' Default value
    VFontGridHeight = 5
END IF
IF VFontGridWidth = 0 then
  ' Default value
    VFontGridWidth = 5
END IF
' Filling look up tables
FOR ii = 0 TO 360
 VFontCOS(ii) = COS(ii * 3.141593 / 180)
 VFontSIN(ii) = SIN(ii * 3.141593 / 180)
NEXT

 '  This is for test purposes : Uncomment to see if your letters are loaded OK
' FOR i = 1 TO 255
'       PRINT "Symbol code"; i
'       PRINT "Range:"; VFontPointer(i, 1); VFontPointer(i, 2)
'       PRINT "Advance:"; VFontPointer(i, 3)
'       PRINT "Data:"
'       FOR j = VFontPointer(i, 1) TO VFontPointer(i, 2)
'          PRINT VFontData(j, 1);" ";VFontData(j, 2),"     ",VFontData(j, 3);" ";VFontData(j, 4)
'       NEXT
'      PRINT "--------------------------------------------"
'     a$ = input$(1)
' NEXT
END SUB

' This is internal function used in InitVFont
FUNCTION RetSymbol (nnn, aa$)  as string
  aa$ = LTRIM$((RTRIM$(aa$)))
  DIM nnm AS SINGLE
  nnm = -1
  DIM nnm1 AS SINGLE
  BegPos = 1
  EndPos = 1
  IF nnn = 1 THEN
      ppp = INSTR(aa$, ",")
      ppps$ = MID$(aa$, 1, ppp - 1)
     ' nnm1 = VAL(ppps$)
      IF nnm1 <> 0 THEN
          nnm = nnm1
     END IF
  ELSE
     prpos = 1
     FOR ii = 1 TO nnn
        prpos = EndPos + 1
        EndPos = INSTR(prpos, aa$, ",")
     NEXT
     IF EndPos < prpos THEN
       ' PRINT aa$
       ' PRINT "Error in parsing line:"
       ' PRINT "Digit N"; nnn, "End position."; EndPos, "Beg. position"; prpos
       ' sss$ = INPUT$(1)
     END IF
     ppps$ = MID$(aa$, prpos, (EndPos - prpos))
  END IF
  RetSymbol = ppps$
END FUNCTION

SUB VPrintAng (xx, yy, text$, clr, xf, yf, angle)
DIM CurCOS AS SINGLE
DIM CurSIN AS SINGLE
CPX = xx
CPY = yy
CurCOS = VFontCOS(angle)
CurSIN = VFontSIN(angle)
  FOR i = 1 TO LEN(text$)
    lt$ = MID$(text$, i, 1)
    lt1 = ASC(lt$)
    FOR ii = VFontPointer(lt1, 1) TO VFontPointer(lt1, 2)
     x1 = xx + ((CPX - xx + VFontData(ii, 1) * xf) * CurCOS + (CPY - yy + VFontData(ii, 2) * yf) * CurSIN)
     y1 = yy + (-1*(CPX - xx + VFontData(ii, 1) * xf) * CurSIN + (CPY - yy + VFontData(ii, 2) * yf) * CurCOS)
     x2 = xx + ((CPX - xx + VFontData(ii, 3) * xf) * CurCOS + (CPY - yy + VFontData(ii, 4) * yf) * CurSIN)
     y2 = yy + (-1*(CPX - xx + VFontData(ii, 3) * xf) * CurSIN + (CPY - yy + VFontData(ii, 4) * yf) * CurCOS)
     ScrArea.LINE (x1, y1, x2, y2, clr)
    NEXT
    CPX = CPX + VFontPointer(lt1, 3) * xf
  NEXT

END SUB