home *** CD-ROM | disk | FTP | other *** search
/ AMOS PD CD / amospdcd.iso / 076-100 / apd076 / font_convert.amos / font_convert.amosSourceCode < prev   
AMOS Source Code  |  1990-11-07  |  4KB  |  151 lines
  1. '----------------------------------------------------------------------------
  2. ' FONT CONVERTER by Francois Lionet
  3. ' AMOS Basic (c) Mandarin / Jawx 1990
  4. '----------------------------------------------------------------------------
  5. Curs Off : Flash Off : Fade 2,0,0,0 : Wait 32
  6. TITLE
  7. ALERT["...Looking to disc fonts..."]
  8. Fade 8,0,0,$EEE
  9. Get Fonts 
  10. '--------------- 
  11. ' Build up menu
  12. '--------------- 
  13. Menu$(1)=" Choose font "
  14. For N=1 To 50
  15.    If Font$(N)<>""
  16.       If Val(Mid$(Font$(N),31))=8
  17.          Menu$(1,N)=Font$(N)
  18.       End If 
  19.    End If 
  20. Next 
  21. Menu$(2)=" Disk "
  22. Menu$(2,1)=" Save font to current AMOS folder "
  23. Menu$(2,2)=" Save font to another AMOS disk   "
  24. Menu$(2,3)="----------------------------------" : Menu Inactive(2,3)
  25. Menu$(2,4)=" Quit                             "
  26. Set Menu(2,1) To 10,-64
  27. Menu On 
  28. '----------------- 
  29. ' TEST loop
  30. '----------------- 
  31. Do 
  32.    If FLAG=0
  33.       ALERT["Please select a font with menu"]
  34.    Else 
  35.       ALERT["Please select a menu option"]
  36.    End If 
  37.    Repeat : Until Choice
  38.    On Choice(1) Gosub MNFONT,MNDISK
  39.    TITLE
  40. Loop 
  41. ' ---> Font menu 
  42. MNFONT:
  43. Menu Off 
  44. MAKEFONT[Choice(2)]
  45. Set Font 2 : Menu Calc : Menu On 
  46. Return 
  47. ' ---> Disk menu 
  48. MNDISK:
  49. If Choice(2)=1 : SVFONT[":AMOS_System/Default.Font"] : End If 
  50. If Choice(2)=2 : SVFONT[Fsel$("Default.Font","","Please select DEFAULT.FONT file","in AMOS_System folder...")] : End If 
  51. If Choice(2)=4 : End : End If 
  52. Return 
  53. '
  54. Procedure SVFONT[N$]
  55.    Shared FLAG
  56.    If FLAG=0 : ALERT["Font not loaded!"] : Bell : Wait 200 : Pop Proc : End If 
  57.    If N$="" : ALERT["Not done"] : Bell : Wait 100 : Pop Proc : End If 
  58.    ALERT["Saving..."]
  59.    Bsave N$,Start(10) To Start(10)+256*8
  60. End Proc
  61. '
  62. Procedure TITLE
  63.    Clw 
  64.    Centre At(,10)+Border$("AMOS Basic Font Converter",2)
  65. End Proc
  66. '
  67. Procedure ALERT[A$]
  68.    Centre At(,22)+Space$(39)
  69.    Centre At(,22)+A$
  70. End Proc
  71. '
  72. Procedure MAKEFONT[F]
  73.    Shared FLAG
  74.    FLAG=False
  75.    Set Font F
  76.    Clw 
  77.    '
  78.    ' Space for new font 
  79.    Erase 10 : Reserve As Work 10,8*256 : AD=Start(10)+32*8
  80.    '
  81.    ' Reads current font 
  82.    RASTPORT=Areg(0)
  83.    AFONT=Leek(RASTPORT+52)
  84.    CDATA=Leek(AFONT+34)
  85.    CMOD=Deek(AFONT+38)
  86.    CHI=Deek(AFONT+20)
  87.    COFFSET=Leek(AFONT+40)
  88.    CFIRST=Peek(AFONT+32)
  89.    CEND=Peek(AFONT+33)
  90.    PROP=Btst(5,Peek(RASTPORT+23))
  91.    If CHI<>8 or PROP : BADFONT : Pop Proc : End If 
  92.    '
  93.    ' Conversion loop
  94.    ALERT["Processing font"]
  95.    Print At(16,8)+Border$(At(16+8,8+7),1)
  96.    For CC=32 To 255
  97.       If CC>=CFIRST and CC<=CEND
  98.          T=Deek(COFFSET+(CC-CFIRST)*4) : COFF=T/8 : CBIT=T mod 8
  99.          CNBIT=Deek(COFFSET+(CC-CFIRST)*4+2)
  100.          If CNBIT<>8 : BADFONT : Pop Proc : End If 
  101.          Locate 26,8
  102.          For Y=0 To CHI-1
  103.             CAD=CDATA+CMOD*Y+COFF
  104.             N=CBIT
  105.             Locate 16,8+Y
  106.             PP=0
  107.             For L=0 To CNBIT-1
  108.                P=Peek(CAD)
  109.                If Btst(7-N,P)
  110.                   Bset 7-L,PP
  111.                   Print "*";
  112.                Else 
  113.                   Print " ";
  114.                End If 
  115.                Inc N
  116.                If N>8
  117.                   Inc CAD : N=0
  118.                End If 
  119.             Next 
  120.             Poke AD,PP : Inc AD
  121.          Next 
  122.       Else 
  123.          For L=0 To 7
  124.             Poke AD,0 : Inc AD
  125.          Next 
  126.       End If 
  127.    Next 
  128.    '
  129.    ' Add border characters
  130.    For L=0 To 32*8-1
  131.       Poke Start(10)+L,Peek(Start(9)+L)
  132.       Poke Start(10)+128*8+L,Peek(Start(9)+32*8+L)
  133.    Next 
  134.    '
  135.    ' One character set in memory
  136.    Clw 
  137.    FLAG=True
  138. End Proc
  139. '
  140. Procedure BADFONT
  141.    Bell 
  142.    Clw 
  143.    Centre At(,10)+"I can't use this font,"
  144.    Centre At(,12)+"I need a 8 pixels FIXED WIDTH font!"
  145.    Centre At(,14)+"You can use the Font Editor from"
  146.    Centre At(,15)+"workbench to convert the font"
  147.    Centre At(,16)+"to fixed width..."
  148.    Centre At(,22)+"... Press mousekey to go on ..."
  149.    Repeat : Until Mouse Click
  150.    Clw 
  151. End Proc