MODULE FontLIB                                            ! VERSION = 2.0
! =======================================================================
! True BASIC, Inc
! 12 Commerce Avenue
! West Lebanon, New Hampshire 03784-9758
! (800) 872-2742,  (603) 298-8517
! =======================================================================
! Author: Paul Castonguay
! =======================================================================
!
! PURPOSE: To support the Amiga's diskbased fonts.
!
!
! REQUIRED REFERENCE:
!
!       LIBRARY "{AmigaTools}FontLIB*"
!
!    To find out more about how libraries are used in True BASIC, refer
!    to your True BASIC Reference Manual, or any of a number of texts
!    available from True BASIC, Inc.
!
!
! DESCRIPTION:
!
!    This MODULE contains eleven (so far) routines to help you enhance
!    your True BASIC programs by allowing you to use any of the Amiga's
!    disk based fonts.  Note that to render custom fonts to screen you
!    should use True BASIC's PLOT TEXT statement, rather than the usual
!    PRINT.  See my example program (in the Examples drawer) for how to
!    use the Amiga's diskbased fonts from within your True BASIC programs.
!
!
! WARNING:
! --------
!
!          A SET MODE within your program causes the active
!             font to change back to the system default.
!
!
!                            LIBRARY ROUTINES
!                            ----------------
!
!            PUBLIC                                 PRIVATE (*)
!     ------------------                      --------------------
!     FUNCTION ASK_Font                       FUNCTION Open_Disk_Font
!     FUNCTION ASK_Spacing
!     FUNCTION Open_Font
!     SUB      Close_Font
!     SUB      SET_Font
!     SUB      SET_Spacing
!     SUB      SET_SysFont
!     SUB      SET_Underlined
!     SUB      SET_Bold
!     SUB      SET_Italics
!     SUB      SET_Normal
!
!
! You will find instructions on the use of the PUBLIC routines of this
! LIBRARY in the text which follows.  You can view them from True BASIC's
! editor by using its search feature.  Search for the word FUNCTION or
! SUBROUTINE, followed by a colon, followed by a single space, and finally,
! followed by the name of the routine you want to use.  For example, to
! view instructions on the use of Open_Font, search for the string:
!
!         SUBROUTINE: Open_Font
!
!
!
! (*) PRIVATE routines are not available to the programmer from outside
!     a MODULE.  Thus they are protected from being used in ways that 
!     were not intended by their designers.  In addition, you need not
!     worry about the names of routines within your own programs
!     conflicting with those of PRIVATE routines within a MODULE.  True
!     BASIC protects you from such conflicts.  All this is a manifestation
!     of the formal principle in computer science called "Information
!     Hiding".  True BASIC fully supports this principle.
!
!
!
!
! EXCEPTIONS:
!
!  ERROR #      ERROR STRING                           OCCURS IN ROUTINE
!  -------   -----------------------------            -------------------
!    900     Cannot open font                         Open_Font
!    901     Zero font address                        SET_Font
!                                                     Close_Font
!    902     Spacing out of range                     SET_Spacing
!
!
!
! LIBRARIES USED:
!
!    {AmigaTools}exec*
!    {AmigaTools}diskfont*
!    {AmigaTools}graphics*
!    {AmigaTools}amiga*
!
!
!
!                     *****************************
!                     ***  HOW TO USE ROUTINES  ***
!                     *****************************
!
!
! -----------------------------------------------------------------------
! FUNCTION: Ask_Font
! -----------------------------------------------------------------------
! This function returns the address of the currently active font.
!
!
!    LIBRARY "{AmigaTools}FontLIB*"
!    DECLARE FUNCTION Ask_Font
!
!    LET CurrentFont = Ask_Font
!
!
! Use this function when you need to confirm that the currently active
! font is the one you want.  For example, to ensure that you are
! using Diamond20:
!
!
!    IF Diamond20 = Ask_Font THEN
!       CALL SET_Font(Diamond20)
!    END IF
!
!
! This routine is also useful for executing different sections of code
! based on the currently active font:
!
!
!    LET CurrentFont = Ask_Font
!
!    SELECT CASE CurrentFont
!
!       CASE Diamond12
!          ...
!
!       CASE Diamond20
!          ...
!
!       CASE ELSE
!
!    END SELECT
!
! 
! WARNING:
!
!    Don't forget to declare Ask_Font as a function, otherwise True BASIC
!    will treat the name as a numeric variable and you will have a heck
!    of a time trying to figure out why your program doesn't work as
!    intended.
!
! -----------------------------------------------------------------------
! FUNCTION: Ask_Spacing
! -----------------------------------------------------------------------
! This function returns the character spacing of the currently active
! font.  Character spacing is measured in pixels.
!
!
!    LIBRARY "{AmigaTools}FontLIB*"
!    DECLARE FUNCTION Ask_Spacing
!
!    LET CurrentSpacing = Ask_Spacing
!
!
! WARNING:
!
!    Don't forget to declare Ask_Spacing as a function, otherwise True
!    BASIC will treat the name as a numeric variable and you will have
!    a heck of a time trying to figure out why your program doesn't work
!    as intended.
!
! -----------------------------------------------------------------------
! SUBROUTINE: SET_Font
! -----------------------------------------------------------------------
! This subroutine is used to switch the currently active font to one that
! has been previously opened.  This routine takes one INPUT argument, the
! variable used to store the address of the previously opened font.  An
! exception is generated if you accidentally pass a zero value for the
! font.  If the address you pass does not in fact correspond to a
! previously opened font, you will crash your machine!
!
! To first open a font you must use the Open_Font function within this
! MODULE.
!
!
!    LIBRARY "{AmigaTools}FontLIB*"
!    DECLARE FUNCTION SET_Font
!
!    CALL SET_Font(Diamond20)
!
!
! EXCEPTIONS:
!
!    901        Zero font address.
!
!
! -----------------------------------------------------------------------
! SUBROUTINE: SET_Spacing
! -----------------------------------------------------------------------
! This subroutine is used to adjust the spacing between characters of
! text displayed in the currently active font.  The space distance is
! measured in pixels and the allowable range is 0 to 25.  An exception
! is generated if you try to set the spacing to values outside that
! range.  Use this routine to improve the appearance of text when using
! different sized fonts.  There is no ideal spacing.  It depends on the
! application and your personal taste.  However, a general rule is that
! the larger the font size, the more spacing you will want to add.
!
!
!    LIBRARY "{AmigaTools}FontLIB*"
!    DECLARE FUNCTION SET_Spacing
!
!    CALL SET_Spacing(2)
!
!
! EXCEPTIONS:
!
!    902        Spacing out of range.
!
!
! -----------------------------------------------------------------------
! SUBROUTINE: SET_SYSFont
! -----------------------------------------------------------------------
! This subroutine switches the font to the one that was active when your
! program started.  It is always prudent on the Amiga to restore all
! conditions to the way you found them before your program terminates.
!
!
! -----------------------------------------------------------------------
! FUNCTION: Open_Font
! -----------------------------------------------------------------------
! This function is used to make different fonts available to your program.
! It takes two INPUT arguments, the size of the font, expressed as a
! numeric value, followed by its name, expressed as a string.  
!
!    LET ProgramFont = Open_Font(FontSize, FontName$)
!
! To find out the available sizes for a particular font on your system,
! use the AmigaDOS dir command from a SHELL window.  For example, if
! you enter the following command on any standard Amiga system:
!
!    dir fonts:ruby
!
! ... you will see reported the following filenames:
!
!  12                 15
!  8
!
! If you prefer to work from True BASIC's COMMAND window, enter the
! following:
!
!    CD FONTS:Ruby
!    FILES
!
! ... and you will see reported:
!
!    12         15        8
!
! But don't forget to CD back to your working directory, otherwise you
! will be saving your True BASIC programs into your system's font
! directory.  Yikes!
!
!    CD True BASIC:TBWork
!
! Note that font sizes are also called point sizes.
!
! As you can see, each font is saved in a file whose name corresponds to
! its point size.  Use those same sizes as a numeric argument to this
! Open_Font routine.
!
! The second argument of this Open_Font function is the name of the font
! that you want.  To see the names currently installed on your system,
! enter the following command into an AmigaDOS SHELL window:
!
!    dir FONTS:
!
! ... and you will see a list of directories whose names correspond to
! the fonts on your system, as well as a list of specification files for
! each one.  The specification filename consist of the name of the font
! with a ".font" appended to the end.  Use the name of the specification
! file as a second argument to this Open_Font function.  For example, to
! specify diamond font, use the string "diamond.font".
!
! Opening a font makes it available to your program, but it does not
! make it active.  To do that you must use the SET_Font routine within
! this MODULE.  Here is an example that makes ruby, 12 point font
! available to your program, followed by a instruction to make it active:
!
!
!    LET MyFont = OpenFont(12, "ruby.font")
!    CALL SET_Font(MyFont)
!
!
! You will find it helpful to use informative variable names for your
! fonts.  I like to use the name and the size appended together, as in
! Diamond20 and Sapphire14.
!
! Each call to Open_Font() opens the desired font at the desired size.
! If you want two or more sizes of the same font you must open them
! individually using separate invocations of the Open_Font() function.
!
!    LET Sapphire14 = Open_Font(14, "sapphire.font")
!    LET Sapphire19 = Open_Font(19, "sapphire.font")
!
! An exception is generated if a font of the name and size you ask for
! cannot be found.
!
!
! EXCEPTIONS:
!
!    900           Cannot open font.
!
!
!
! -----------------------------------------------------------------------
! SUBROUTINE: Close_Font
! -----------------------------------------------------------------------
! This subroutine closes all fonts opened by your application, but it
! does not remove them from the system font list.  As a result, if you
! run your program a second time the fonts will be loaded from RAM.
! This saves you from having to reinsert your Workbench disk over and
! over again as you run your program many times from a floppy disk.  
!
! See your Amiga documentation if you need help on where to find or
! install fonts on your system.
! 
!
! -----------------------------------------------------------------------
! SUBROUTINE: SET_Underlined
! -----------------------------------------------------------------------
! This subroutine changes the style of the currently active font to
! UNDERLINED.
!
!
! -----------------------------------------------------------------------
! SUBROUTINE: SET_Bold
! -----------------------------------------------------------------------
! This subroutine changes the style of the currently active font to
! BOLD.
!
!
! -----------------------------------------------------------------------
! SUBROUTINE: SET_Italics
! -----------------------------------------------------------------------
! This subroutine changes the style of the currently active font to
! ITALICS.
!
!
! -----------------------------------------------------------------------
! SUBROUTINE: SET_Normal
! -----------------------------------------------------------------------
! This subroutine changes the style of the currently active font to
! NORMAL.  Use this routine when you want to cancel previous style
! settings.
!
!
! -----------------------------------------------------------------------



!                         **********************
!                         ***  CODE FOLLOWS  ***
!                         **********************


! ****************************
! PRIVATE routine declarations
! ****************************
PRIVATE Open_Disk_Font



! ****************************
! SHARED variable declarations
! ****************************
SHARE Style
LET Style = 0


!                     ********************************
!                     ***  PUBLIC ROUTINES FOLLOW  ***
!                     ********************************


! =======================================================================
! FUNCTION Ask_Font
! =======================================================================
!
! PURPOSE: To find out what font is currently active.
!
!
! SCOPE: PUBLIC
!
!
! RETURNED VALUE:
!
!    Address of the corresponding font structure on system font table.
!
!
! TEMPLATE:
!
!       DECLARE FUNCTION Ask_Font
!
!       LET Current_Font = Ask_Font
!
!
! OPERATION:
!
!    This routine reads the current font from the active RastPort
!    structure.
! ======================================================================
FUNCTION Ask_Font

   LIBRARY "{AmigaTools}amiga*"
   
   DECLARE FUNCTION CurrentRPort, PeekL

   LET Rast_Port = CurrentRPort

   ! **************************************************
   ! Current font address is stored 52 bytes beyond the
   ! beginning of the current RastPort structure.
   ! **************************************************
   LET Ask_Font = PeekL(Rast_Port + 52)

END FUNCTION  ! end of Ask_Font




! =======================================================================
! FUNCTION Ask_Spacing
! =======================================================================
!
! PURPOSE: To find out the current character spacing, in pixels.
!
!
! SCOPE: PUBLIC
!
!
! RETURNED VALUE:
!
!    Number of pixels currently inserted between the characters of
!    text by the system.
!
!
! TEMPLATE:
!
!       DECLARE FUNCTION Ask_Spacing
!
!       LET Current_Spacing = Ask_Spacing
!
!
! OPERATION:
!
!    This routine reads the current character spacing from the active
!    RastPort structure.
! ======================================================================
FUNCTION Ask_Spacing

   LIBRARY "{AmigaTools}amiga*"
   DECLARE FUNCTION CurrentRPort, UPeekW

   ! *****************************
   ! Get required RastPort pointer
   ! *****************************
   LET Rast_Port = CurrentRPort

   ! ***************************************************
   ! Current character spacing is stored 64 bytes beyond 
   ! the beginning of the current RastPort structure.
   ! ***************************************************
   LET Ask_Spacing = UPeekW(Rast_Port + 64)

END FUNCTION  ! end of Ask_Spacing()




! =======================================================================
! SUBROUTINE SET_Font
! =======================================================================
!
! PURPOSE: To make a previously opened font active.
!
!
! SCOPE: PUBLIC
!
!
! PARAMATERS:
!
!    INPUT:
!
!       FontPointer .... Address of a currently opened font.
!
!
! TEMPLATE:
!
!       DECLARE FUNCTION Ask_Spacing
!
!       CALL SET_Font(FontPointer)
!
!
! OPERATION:
!
!    This routine invokes the graphics library function SetFont().
!    An exception is generated if you accidentally pass a zero for
!    a font address.
!
! EXCEPTIONS:
!
!    901          Zero font address.
! ======================================================================
SUB SET_Font(FontPointer)

   LIBRARY "{AmigaTools}graphics*", "{AmigaTools}amiga*"
   DECLARE FUNCTION CurrentRPort, SetFont

   ! *****************************
   ! Get required RastPort pointer
   ! *****************************
   LET Rast_Port = CurrentRPort

   ! *********************************************
   ! Test for accidental passing of a zero address
   ! *********************************************
   IF FontPointer = 0 THEN
      CALL SET_SYSFont
      CAUSE EXCEPTION 901, "Zero font address."
   END IF

   LET valid = SetFont(Rast_Port, FontPointer)

END SUB  ! End of SET_Font() 




! =======================================================================
! SUBROUTINE SET_Spacing
! =======================================================================
!
! PURPOSE: To adjust the spacing that the system inserts between the
!          characters of displayed text.
!
!
! SCOPE: PUBLIC
!
!
! PARAMATERS:
!
!    INPUT:
!
!       Pixels .... Desired spacing.
!
!
! TEMPLATE:
!
!       CALL SET_Spacing(4)
!
!
! OPERATION:
!
!    This routine pokes the desired character spacing into the active
!    RastPort structure.  The range allowed is 1 to 25.  An exception
!    is generated if you ask for an out of range spacing.
!
!
! EXCEPTIONS:
!
!    902      Spacing out of range.
! ======================================================================
SUB SET_Spacing(Pixels)

   LIBRARY "{AmigaTools}amiga*"
   DECLARE FUNCTION CurrentRPort

   ! *****************************
   ! Get required RastPort pointer
   ! *****************************
   LET Rast_Port = CurrentRPort

   IF Pixels >= 0 AND Pixels < 26 THEN

      ! ******************************************
      ! Legal value for spacing.  Poke it in place
      ! ******************************************
      CALL PokeW(Rast_Port + 64, Pixels)

   ELSE

      ! ***********************************
      !      Illegal value for spacing
      ! Switch to original font and spacing
      ! *********************************** 
      CALL SET_SYSFont     
      CAUSE EXCEPTION 902, "Spacing out of range."

   END IF

END SUB    ! End of SET_Spacing()




! =======================================================================
! FUNCTION SET_SYSFont
! =======================================================================
!
! PURPOSE: To make the system default font active.
!
!
! SCOPE: PUBLIC
!
!
! TEMPLATE:
!
!       CALL RESET_Font
!
!
! OPERATION:
!
!    This routine reads the system default font from the current
!    Window structure and switches to it by invoking the SET_Font()
!    routine of this library.
! ======================================================================
SUB SET_SYSFont

   LIBRARY "{AmigaTools}amiga*"
   DECLARE FUNCTION CurrentWindow, UPeekL

      ! ***********************************
      ! Switch to original font and spacing
      ! ***********************************      
      LET This_Window = CurrentWindow
      LET First_Font = UPeekL(This_Window + 128)
      CALL Set_Font(First_Font)
      CALL Set_Spacing(0)

END SUB    ! End of RESET_Font




! =======================================================================
! FUNCTION Open_Font
! =======================================================================
!
! PURPOSE: To make a new font available to your program.
!
!
! SCOPE: PUBLIC
!
!
! PARAMETERS:
!
!    INPUT:
!
!       Font_Height .... Height of font
!       Font_Name$ ..... Name of the font on your system
!
!
! RETURNED VALUE:
!
!    Address of the corresponding font structure on system font table.
!    Use this value for subsequent calls to Set_Font and Close_Font.
!
!
! TEMPLATE:
!
!       DECLARE FUNCTION Open_Font
!
!       LET Diamond20 = Open_Font(20, "diamond.font")
!
!
! OPERATION:
!
!    This routine first tries to open the font from the system font
!    table in RAM.  If it is not there it tries to get the font from
!    disk by calling the Open_Disk_Font() function within this library.
!    An exception is generated if the font cannot be found.
! ======================================================================
FUNCTION Open_Font(Font_Height, Font_Name$)

   LIBRARY "{AmigaTools}graphics*", "{AmigaTools}amiga*"
   
   DECLARE FUNCTION Addr, Nullt$, PeekL, PeekW, OpenFont, Open_Disk_Font


   ! **************************************************************
   ! Try to open font first from ram.  If it's on the sytem font
   ! list you will get that address.  If not, you will get 0.
   ! **************************************************************

   ! ********************************************************
   ! Make a fake TextAttr structure for the desired font and
   ! and get its address to use as an argument for OpenFont()
   ! ********************************************************
   LET ft_name$ = ""
   LET ft_name$ = Nullt$(Font_Name$)
   LET ta_YSize = Font_Height
   LET ta_Style = 0
   LET ta_Flags = 0
   LET ft_data$ = ""
   CALL packb(ft_data$, maxnum, 32, Addr(ft_name$))
   CALL packb(ft_data$, maxnum, 16, ta_YSize)
   CALL packb(ft_data$, maxnum, 8, ta_Style)
   CALL packb(ft_data$, maxnum, 8, ta_Flags)
   LET ft_addr = Addr(ft_data$)

   ! ******************
   ! Open font from RAM
   ! ******************
   LET Font_Address = OpenFont(ft_addr)

   ! *******************
   !        Test 
   ! *******************
   IF Font_Address = 0 THEN

      ! ***************************
      !        NOT SUCCESSFUL
      ! open desired font from disk
      ! ***************************
      LET Font_Address = Open_Disk_Font(Font_Height, Font_Name$)
                
   ELSE

      ! ***************************
      !        SUCCESSFUL
      !        Verify size
      ! ***************************
      LET Ft_Height = PeekW(Font_Address+20)
      IF Ft_Height <> Font_Height THEN
     
         ! ***************************
         !     WRONG SIZE RECEIVED
         ! open desired font from disk
         ! ***************************
         LET Font_Address = Open_Disk_Font(Font_Height, Font_Name$)
             
      END IF

   END IF

   ! ************************************************
   ! Return address of new font or generate exception
   ! ************************************************
   IF Font_Address = 0 THEN
      CALL SET_SYSFont
      CAUSE ERROR 900, "Cannot open font."
   ELSE
      LET Open_Font = Font_Address
   END IF


END FUNCTION  ! End of Open_Font()




! =======================================================================
! FUNCTION Close_Font
! =======================================================================
!
! PURPOSE: To return the resources of a font back to the system.
!
!
! SCOPE: PUBLIC
!
!
! PARAMETERS:
!
!    INPUT:
!
!       Font_Pointer .... Address of previously opened font.
!
!
! TEMPLATE:
!
!       CALL Close_Font(Diamond20)
!
!
! OPERATION:
!
!    This routine invokes the  CloseFont() function from the Amiga's
!    "graphics.library".  An exception is generated if you accidentally
!    pass a zero for a font address.
!
! EXCEPTION:
!
!    901          Zero font address.
! ======================================================================
SUB Close_Font(Font_Pointer)
   
   LIBRARY "{AmigaTools}graphics*", "{AmigaTools}amiga*"
   DECLARE FUNCTION CloseFont

   IF Font_Pointer = 0 THEN
      CALL SET_SYSFont
      CAUSE EXCEPTION 901, "Zero font address."
   END IF

   LET valid = CloseFont(Font_Pointer)

END SUB  ! end of Close_Font()




! =======================================================================
! SUBROUTINE Set_Underlined
! =======================================================================
!
! PURPOSE: Adjust the font style in the current rastport to underline.
!
!
! SCOPE: PUBLIC
!
!
! TEMPLATE:
!
!       CALL SET_Underlined
!
!
! OPERATION:
!
!    This routine invokes the SetSoftStyle() function from the Amiga's
!    "graphics.library".
! ======================================================================
SUB SET_Underlined

   LIBRARY "{AmigaTools}graphics*", "{AmigaTools}amiga*"

   DECLARE FUNCTION CurrentRPort, SetSoftStyle

   LET RastPort = CurrentRPort
   LET Style = Style + 1

   LET valid = SetSoftStyle(RastPort, Style, 2^32)

END SUB




! =======================================================================
! SUBROUTINE SET_Bold
! =======================================================================
!
! PURPOSE: Adjust the font style in the current rastport to bold.
!
!
! SCOPE: PUBLIC
!
!
! TEMPLATE:
!
!       CALL SET_Bold
!
!
! OPERATION:
!
!    This routine invokes the SetSoftStyle() function from the Amiga's
!    "graphics.library".
! ======================================================================
SUB SET_Bold

   LIBRARY "{AmigaTools}graphics*", "{AmigaTools}amiga*"

   DECLARE FUNCTION CurrentRPort, SetSoftStyle

   LET RastPort = CurrentRPort
   LET Style = Style + 2

   LET valid = SetSoftStyle(RastPort, Style, 2^32)

END SUB




! =======================================================================
! SUBROUTINE Set_Normal
! =======================================================================
!
! PURPOSE: Adjust the font style in the current rastport to normal.
!
!
! SCOPE: PUBLIC
!
!
! TEMPLATE:
!
!       CALL SET_Normal
!
!
! OPERATION:
!
!    This routine invokes the SetSoftStyle() function from the Amiga's
!    "graphics.library".
! ======================================================================
SUB SET_Normal

   LIBRARY "{AmigaTools}graphics*", "{AmigaTools}amiga*"

   DECLARE FUNCTION CurrentRPort, SetSoftStyle

   LET RastPort = CurrentRPort
   LET Style = 0

   LET valid = SetSoftStyle(RastPort, Style, 2^32)

END SUB




! =======================================================================
! SUBROUTINE Set_Italics
! =======================================================================
!
! PURPOSE: Adjust the font style in the current rastport to italics.
!
!
! SCOPE: PUBLIC
!
!
! TEMPLATE:
!
!       CALL SET_Italics
!
!
! OPERATION:
!
!    This routine invokes the SetSoftStyle() function from the Amiga's
!    "graphics.library".
! ======================================================================
SUB SET_Italics

   LIBRARY "{AmigaTools}graphics*", "{AmigaTools}amiga*"

   DECLARE FUNCTION CurrentRPort, SetSoftStyle

   LET RastPort = CurrentRPort
   LET Style = Style + 4

   LET valid = SetSoftStyle(RastPort, Style, 2^32)

END SUB




!                    *********************************
!                    ***  PRIVATE ROUTINES FOLLOW  ***
!                    *********************************




! =======================================================================
! FUNCTION Open_Disk_Font
! =======================================================================
!
! PURPOSE: To load onto the system's variable font table a font from
!          the disk.
!
!
! SCOPE: PRIVATE
!
!
! PARAMETERS:
!
!    INPUT:
!
!       Font_Height .... Height of font
!       Font_Name$ ..... Name of the font on your system
!
!
! RETURNED VALUE:
!
!    Address of the corresponding font structure on system font table.
!    Use this value for subsequent calls to Set_Font and Close_Font.
!
!
! TEMPLATE:
!
!       DECLARE FUNCTION Open_Disk_Font
!
!       LET Diamond20 = Open_Disk_Font(20, "diamond.font")
!
!
! OPERATION:
!
!    This routine tries to open the font from the system font device,
!    which is the FONTS: device on disk.  An exception is generated if
!    the font cannot be found.
! ======================================================================
FUNCTION Open_Disk_Font(Font_Height, Font_Name$)

   LIBRARY "{AmigaTools}exec*", "{AmigaTools}diskfont*"
   LIBRARY "{AmigaTools}amiga*"
   
   DECLARE FUNCTION Addr, Nullt$, PeekL, PeekW
   DECLARE FUNCTION OpenLibrary, CloseLibrary, OpenDiskFont


   ! *********************************
   !     Open the diskfont library
   ! *********************************
   LET library_name$ = Nullt$("diskfont.library")
   LET library_addr  = Addr(library_name$)    
   LET DiskfontBase = OpenLibrary(library_addr, 0)

   ! ***********************
   !     Verify success
   ! ***********************
   IF DiskfontBase = 0 then
      LET Open_Disk_Font = 0
      EXIT FUNCTION
   END IF

   ! *****************************************************
   ! Make a fake TextAttr structure for the desired font
   ! and get address to use as argument for OpenDiskFont()
   ! *****************************************************
   let ft_name$ = ""
   let ft_name$ = Nullt$(Font_Name$)
   let ta_YSize = Font_Height
   let ta_Style = 0
   let ta_Flags = 0
   let ft_data$ = ""
   call packb(ft_data$, maxnum, 32, Addr(ft_name$))
   call packb(ft_data$, maxnum, 16, ta_YSize)
   call packb(ft_data$, maxnum, 8, ta_Style)
   call packb(ft_data$, maxnum, 8, ta_Flags)
   LET ft_addr = Addr(ft_data$)

   ! *******************
   ! Open font from disk
   ! *******************
   LET Font_Address = OpenDiskFont(ft_addr, DiskfontBase)
   
   ! *******************
   !        Test 
   ! *******************
   IF Font_Address = 0 THEN

      ! *******************************************
      !               NOT SUCCESSFUL
      ! *******************************************
      CALL SET_SYSFont
      LET Open_Disk_Font = 0
      EXIT FUNCTION

   ELSE

      ! *******************************************
      !                 SUCCESSFUL
      !     Verify if size received is correct
      ! *******************************************
      LET Ft_Height = Peekw(Font_Address+20)
      IF Ft_Height <> Font_Height THEN

         ! **************************
         !     WRONG SIZE RECEIVED
         ! Desired size not available
         ! **************************
         CALL SET_SYSFont
         LET Open_Disk_Font = 0
         EXIT FUNCTION

      END IF

   END IF

   ! ***************************************************
   ! Close the diskfont library.  It's no longer needed.
   ! ***************************************************
   let valid = CloseLibrary(DiskfontBase)

   ! ***********************
   ! Return the font address
   ! ***********************
   LET Open_Disk_Font = Font_Address


END FUNCTION    ! End of Open_Disk_Font()




END MODULE