/*#######################################################################*/
/*                                                                       */
/*       Fontaloger V1.2 - Final Writer Arexx Script                     */
/*       Andrew M. Haas (03-Sep-98)                                      */
/*                                                                       */
/*       EMail: AndyHaas@wcnet.org                                       */
/*                                                                       */
/*       Fontaloger will print all fonts in a specified path.        .   */
/*       The font name will be printed using a common font and a         */
/*       test string will be printed using the actual font.              */
/*                                                                       */
/*       -- Requires the following AmigaDOS commands --                  */
/*          RequestFile, RequestChoice, Wait, Delete,                    */
/*          Run, Rename, List, Sort, Copy                                */
/*                                                                       */
/*#######################################################################*/

/* $VER: Fontaloger 1.2 (3.9.98)
*/

/* #########################  ARexx Setup ############################## */

options results
Title = "Fontaloger V1.2 (03-Sep-98) "
Credit = "by Andrew Haas "
Email = "AndyHaas@wcnet.org"
SAY Title || Credit
fwavail = SHOW(PORTS, 'FINALW.1')
IF fwavail = 0 THEN DO
    ADDRESS COMMAND 'RUN >NIL: FinalWriter:FinalWriter' /* take a guess at assign */
    ADDRESS COMMAND 'WAIT 8'
    fwavail = SHOW(PORTS, 'FINALW.1')
    IF fwavail = 0 THEN DO
        SAY "Fontaloger: unable to locate Final Writer - please start Final Writer first."
        EXIT 20
        END
    END
ADDRESS 'FINALW.1'
ScreenToFront           /* bring the Final Writer screen to the front */
mpi = 720               /* needed right away - micorpoints per inch  */

/* ##################### Get user configuration ####################### */

CALL GETCONFIG()    /* get Fontaloger configuration */

CALL GETLAYOUT()    /* get default page settings */

IF ask_everything = 1 THEN DO

    statsl1 = '"' || Title '"'
    statsl2 = '"' || Credit '"'
    statsl3 = '"' || Email '"'
    ShowMessage 1 0 statsl1 statsl2 statsl3 '"  Continue   " "Abort" ""'
    IF RESULT = 2 THEN DO
        SAY "User abort"
        EXIT 5
        END

    ShowMessage 2 0 '"Select print mode" "" "" "Autoprint" "  Page prompt   " "List to file"'
    print_mode = Result
    IF print_mode = 3 then DO   /* list all fonts to a file in RAM Disk */
        autoprint = 0   /* 0 = no printing */
        pagepause = 0   /* 0 = no page requesters */
        listtofile = 1  /* list all fonts to a file in RAM Disk */
        END
    ELSE IF print_mode = 2 then DO  /* page pause */
        autoprint = 0   /* 0 = print only if told to at page pause */
        pagepause = 1   /* 1 = present requester to proceed printing */
        END
    ELSE DO     /* autoprint */
        autoprint = 1   /* 1 = automatically print pages */
        pagepause = 0   /* 0 = don't present requester to proceed printing */
        END

    ShowMessage 3 0 '"How many columns?" "" "" "One" "Two" "Three"'
    max_columns = Result

    IF listtofile = 0 THEN DO   /* don't bother asking this question in listtofile */
        ShowMessage 1 0 '"Select page format: A) Path in header" "B) Full path included with each font" "(format B allows multiple font paths)" "  A" "B" "Abort"'
        page_mode = Result - 1  /* valid result is 1 or 2 */
        IF RESULT = 3 THEN DO
            SAY "User abort"
            EXIT 5
            END
        END
    
    ShowMessage 1 0 '"Select sorting method:" "A) Sort by path+name" "B) Sort by name, then path" "A" "B" "Abort"'
    sort_mode = Result - 1  /* valid result is 1 or 2 */
    IF RESULT = 3 THEN DO
        SAY "User abort"
        EXIT 5
        END


    CALL GETLAYOUT()    /* update page settings with user input */

    END

CALL FWCLEAR()  /* clear FW document, set view, measure, pagesetup etc. */
GetPageSetup WIDTH HEIGHT   /* get stats from FinalWriter */
Parse Var RESULT page_width page_height /* page size 8.5*mpi x 11*mpi for US letter */

/* ################# One-time calculations and inits ################### */

IF UPPER(max_rows) = "AUTO" THEN DO     /* calculate the number of font rows */
    font_vspace = page_height - top_margin - header_space - bottom_margin
    max_rows = TRUNC(font_vspace/offset_font_to_font)
    END
work_width = page_width - left_margin - right_margin
column_width = TRUNC(work_width/max_columns)    /* max width of font sample text block */
maxtswidth = TRUNC(column_width * (LENGTH(TestString) - 1) / LENGTH(TestString)) 
    /* max width (micropoints) of TestString on page, leave 1 char blank between cols */
tfont_margin = TRUNC(top_margin + header_space)
row = 0     /* start at top of page */
column = 0  /* start column at left */
page = 1    /* start at page 1 */
printed =  1    /* disable printing on immediate End-Of-File (abnormal condition) */
badfonts = 0    /* initialize counter to 'no bad fonts so far' */
fontcount = 0   /* initialize count of good fonts to zero */
pathcount = 0   /* initialize count of separate font paths */

/* ############################ ARexx body ############################# */

Status "FontPath"   /* get current typeface (with path) from Final Writer */
typename = Result   /* store in typename */

/* strip type name from current FW font to leave the font path */
ptr = LASTDIR(typename)    /* find last occurrance of '/' or ':' */
IF ptr > 0 THEN DO
    fwpath = LEFT(typename, ptr)
    END
ELSE DO
    SAY "Illegal path :" fwpath
    EXIT 20
    END

DO WHILE REQUESTPATH()  /* request path(s) to fonts from user until cancel */
                        /* button is pressed or same path is chosen twice */
    IF page_mode = 0 & listtofile = 0 THEN BREAK /* if path is in header then only */
                        /* one path, but listtofile = 1 allows multipath */
    END


defpat = '"' || "~(#?.info) ALL"
IF autoid THEN defpat = defpat || " AutoID"
defpat = defpat || '"'

RESULT = "Cancel"    /* preload RESULT for cancel */
RequestText '"Font pattern..." "Enter font pattern" '|| defpat
FontPattern = Result
IF FontPattern = "Cancel" THEN DO
    SAY "User abort"
    EXIT 5
    END
ptr = POS('AUTOID', UPPER(FontPattern)) /* check for 'AutoID' in pattern */
IF ptr > 0 THEN DO
    autoid = 1  /* set flag for autoidentification of font files using header */
    FontPattern = DELSTR(FontPattern, ptr, 6) /* remove 'AutoID' from FontPattern */
    END
ELSE autoid = 0 /* clear AutoID flag */

                            /* start font list with first or only path */
ADDRESS COMMAND 'List >' || FontFile pathlist.1 'PAT' FontPattern 'FILES LFORMAT' '%s%s'
IF RC > 0 THEN CALL NOFONTS() /* error message & quit */

IF pathcount > 1 THEN DO    /* append remaining path(s) contents to font list */
    DO listptr = 2 to pathcount
        ADDRESS COMMAND 'List >>' || FontFile pathlist.listptr 'PAT' FontPattern 'FILES LFORMAT' '%s%s'
        IF RC > 0 THEN CALL NOFONTS() /* error message & quit */
        END
    END

IF autoid THEN CALL IDENTIFY()  /* screen font list using ID codes and count them */

CALL FSORT()                /* sort fonts by name, then path or by path+name */

IF listtofile = 1 THEN DO   /* replace or create list of fonts for user to view */
    IF EXISTS(FontList) THEN DO
        ADDRESS COMMAND 'Delete >NIL: ' FontList /* Delete */
        END
    ADDRESS COMMAND 'Copy >NIL: ' FontFile FontList
    END

DO WHILE ESTIMATEFONTS()    /* open file and count fonts in FontFile */
    END                     /* also preread items from file to skip pages */

DO count = fontcount TO fontmax - 1 /* last line of file is empty */

    typewithpath = ReadLn('infile')
    Font typewithpath       /* test font - if bad, add to bad fonts list */
    IF RC = 0 THEN DO       /* good font */
        CALL DRAWFONT()     /* draw the font */
        fontcount = fontcount + 1   /* increment count of good fonts */
        END
    ELSE CALL WRITEBADFONT() /* add font name to list of bad fonts */
    END

    /* loop termination */
IF printed = 0 THEN DO
    CALL PRINTHEADER()  /* end of last page - type header on top of page */
    CALL PAGEPRINT()    /* print last page */
    END
CALL CLOSE('infile')
ADDRESS COMMAND 'Delete >NIL: ' FontFile

IF fontcount = 1 THEN DO
    statsl1 = '"' || fontcount || " font on "   /* turn numeric vars into strings */
    END
ELSE DO
    statsl1 = '"' || fontcount || " fonts on "  /* turn numeric vars into strings */
    END
IF page = 1 THEN DO
    statsl1 = statsl1 || page || " page" || '"'
    END
ELSE DO
    statsl1 = statsl1 || page || " pages" || '"'
    END
IF badfonts = 1 THEN DO
    statsl2 = '"' || badfonts || " bad file" || '"'
    END
ELSE DO
    statsl2 = '"' || badfonts || " bad files" || '"'
    END

ShowMessage 1 0 '"Fontaloger stats:"' statsl1 statsl2 '"  Continue   " "" ""'

IF badfonts >= 1 THEN DO
    CALL CLOSE('badfontfile')   /* close list of bad files */
    statsl1 = '"' || Title || Credit || '"'
    statsl3 = '"' || bad_fonts_list || '"'
    ShowMessage 1 0 statsl1 '"A list of bad fonts can be found in:"' statsl3 '"  Continue   " "" ""'
    END

ClearDoc "FORCE"    /* return FW to default settings */

SAY "Done"
EXIT 0

/* ########################################################################### */
/* ########################################################################### */

REQUESTPATH:    /* add a font path to the font path list */

IF pathcount = 0 THEN reqmsg = '"Select font path (Cancel aborts)"'
ELSE DO
    fwpath = pathlist.pathcount /* remember last path selection */
    reqmsg = '"Additional path (Cancel=none)"'
    END
reqcancel = 0   /* clear 'cancel button pressed' flag */

ADDRESS COMMAND 'RequestFile >' FontFile || '.1'  'DRAWER ' fwpath 'TITLE' reqmsg 'PUBSCREEN' public_screen
IF RC = 5 THEN DO
    IF pathcount = 0 THEN DO
        SAY "User abort"
        EXIT 5
        END
    ELSE reqcancel = 1  /* set 'cancel button pressed' flag */
    END
ELSE IF RC > 5 THEN DO  /* if error, retry without public screen */
    ADDRESS COMMAND 'RequestFile >' FontFile || '.1'  'DRAWER ' fwpath 'TITLE' reqmsg
    IF RC = 5 THEN DO
        IF pathcount = 0 THEN DO
            SAY "User abort"
            EXIT 5
            END
        ELSE reqcancel = 1  /* set 'cancel button pressed' flag */
        END
    ELSE IF RC > 5 THEN DO
        SAY "Can't run RequestFile"
        EXIT 20
        END
    ELSE NOP
    ScreenToFront           /* bring the Final Writer screen back to the front */
    END
ELSE NOP

CALL OPEN('pathfile', FontFile || '.1', 'R')    /* this file contains full font path */
typepath = READLN('pathfile')   /* read path to a variable and delete the file */
CALL CLOSE('pathfile')
ADDRESS COMMAND 'Delete >NIL: ' FontFile || '.1'

IF reqcancel = 0 THEN DO    /* user at least thinks he has selected a good path */

    ptr = LASTDIR(typepath)    /* find last occurrance of '/' or ':' */
    IF ptr > 0 THEN DO
        typepath = LEFT(typepath, ptr) || '"' /* remove any filename and append dbl quote */
        END
    ELSE DO
        SAY "Illegal path :" typepath
        EXIT 20
        END

    IF pathcount > 0 THEN DO   /* check validity of path */
        goodpath = 1    /* preset flag indicating that new path is not a duplicate */
    
        DO rpindex = 1 TO pathcount        /* look for identical previous path */
            IF pathlist.rpindex = typepath THEN goodpath = 0    /* no good */
            END
        IF goodpath = 1 THEN DO /* path is not a duplicate - add it to the list */
            pathcount = pathcount + 1       /* increment count of paths in list */
            pathlist.pathcount = typepath       /* add new path to paths list */
            END
        ELSE DO
            RETURN 0   /* duplicate entry - done adding path list entries */
            END
        END
    ELSE DO   /* This is the first path in the list */
        pathcount = 1       /* set count of paths in list to 1 */
        pathlist.pathcount = typepath      /* add new path to paths list */
        END
    END

IF reqcancel THEN RETURN 0      /* done adding path list entries */
ELSE RETURN 1  /* force a recall of REQUESTPATH to add more path entries */

/* ########################################################################### */
/* ########################################################################### */

ESTIMATEFONTS: /* open FontFile count the number of lines and estimate paper use */
               /* also, give option to skip a number of pages */

IF ~autoid THEN DO /* count files if not already counted by IDENTIFY() */
    IF ~OPEN('infile', FontFile, "R") THEN EXIT 10  /* count #of fonts in FontFile */
    fontmax = -1   /* start lines at -1 to give correct count */
    DO WHILE ~EOF('infile')
        CALL READLN('infile')
        fontmax = fontmax + 1   /* count lines */
        END
    CALL CLOSE('infile')
    END

IF ~OPEN('infile', FontFile, "R") THEN EXIT 10 /* reopen file for use this time */

pnum = TRUNC(fontmax / (max_rows * max_columns)) + 1

IF fontmax = 1 THEN DO
    statsl2 = '"' || fontmax || " font which would" || '"' /* assemble line 2 text */
    END
ELSE DO
    statsl2 = '"' || fontmax || " fonts which would" || '"' /* assemble line 2 text */
    END
IF pnum = 1 THEN DO
    statsl3 = '"' || "require " || pnum || " page" || '"'
    END
ELSE DO
    statsl3 = '"' || "require " || pnum || " pages" || '"'
    END

IF listtofile THEN DO   /* assemble button text */
    button1 = '"' || "  OK   " || '"'
    button2 = '""'
    button3 = '""'
    END
ELSE DO
    button1 = '"' || "  Continue   " || '"'
    button2 = '"' || "Skip pages" || '"'
    button3 = '"' || "Abort" || '"'
    END

ShowMessage 1 0 '"There appear to be "' statsl2 statsl3 button1 button2 button3
statres = RESULT

IF listtofile THEN DO   /* Stop here if just making a list of fonts in RAM Disk */
    CALL CLOSE('infile')
    ADDRESS COMMAND 'Delete >NIL: ' FontFile
    statsl1 = '"' || Title || Credit || '"'
    statsl3 = '"' || FontList || '"'
    ShowMessage 1 0 statsl1 '"A sorted fonts list can be found in:"' statsl3 '"  Done   " "" ""'
    SAY "Done."
    EXIT 0
    END

IF statres = 3 THEN DO
    SAY "User abort"
    EXIT 5
    END

statsl1 = '"' || "Enter starting page number (1-" || pnum || ")" || '"'

IF statres = 2 THEN DO /* Skip pages - preread data for first n pages */
    DO FOREVER
        RESULT = "Cancel"    /* preload RESULT for cancel */
        RequestText '"Skip pages..."' statsl1 '"1"'
        startpage = Result
        IF startpage = "Cancel" THEN DO
            CALL CLOSE('infile') /* close infile to allow re-open on next call */
            RETURN 1 /* 1 = cause re-call of ESTIMATEFONTS */
            END
        index = 0       /* start lines at 0 to give correct count */
        IF startpage >= 1 & startpage <= pnum THEN BREAK    /* check range */
        END

    lskipmax = (startpage-1) * max_rows * max_columns /* calculate lines to eat */

    DO WHILE index < lskipmax
        CALL READLN('infile')
        index = index + 1     /* eat lines */
        END
    page = startpage    /* update page counter */
    fontcount = lskipmax  /* best estimate of current font count for stats */
    END

RETURN 0

/* ########################################################################### */
/* ########################################################################### */

DRAWFONT:   /* draw font name in a standard font and TestString in actual font */

printed = 0 /* this page has not been printed yet */

IF page_mode = 1 THEN DO   /* mode 'B' - full path for each font */

    ptr = LASTDIR(typewithpath)    /* find last occurrance of '/' or ':' */
    ptname = DELSTR(typewithpath, 1, ptr)
    ptpath = DELSTR(typewithpath, ptr)

    IF FontNameModeB = 1 THEN DO    /* fontname [path] */
        IF LENGTH(ptname) + LENGTH(ptpath) + 3 > path_chars_b THEN DO /* max is 74 */
            ptpath = "+" || RIGHT(ptpath, path_chars_b - (LENGTH(ptname) + 4))
            END
        ptlong = ptname || " [" || ptpath || "]"
        say "long:{" || ptlong || "}" LENGTH(ptlong)
        END
    ELSE DO /* path/fontname */
        IF LENGTH(ptname) + LENGTH(ptpath) + 1 > path_chars_b THEN DO /* max is 74 */
            ptpath = "+" || RIGHT(ptpath, path_chars_b - (LENGTH(ptname) + 2))
            END
        ptlong = ptpath || "/" || ptname
        say "long:{" || ptlong || "}" LENGTH(ptlong)
        END

    ptleft = LEFT(ptlong, 37, ' ')  /* chop off at 37 chars - FW limit */

    block_vposition = TRUNC((row * offset_font_to_font) + tfont_margin) /* font v-pos */
    block_hposition = TRUNC((column * column_width) + left_margin) /* font left h-pos */

    TextBlockTypePrefs SIZE path_font_size WIDTH pf_width_b FONT path_font
    DrawTextBlock 1 block_hposition block_vposition ptleft
    GetObjectCoords RESULT

    IF LENGTH(ptlong) > 37 THEN DO  /* create and type right half if necessary */

        ptright = DELSTR(ptlong, 1, 37)

        Parse Var RESULT objpage objleft objtop objwidth objheight  /* get width of block */
        block2_hposition = TRUNC(block_hposition + objwidth) /* right half font h-pos */
        TextBlockTypePrefs SIZE path_font_size WIDTH pf_width_b FONT path_font
        DrawTextBlock 1 block2_hposition block_vposition ptright

        END

    END

ELSE DO /* mode 'A' - path (from font directory only) for each font */

    ptraw = typewithpath
    ptraw = DELSTR(ptraw, 1, (LENGTH(typepath) - 2))  /* remove main path (header) */

    ptr = LASTDIR(ptraw)    /* find last occurrance of '/' or ':' */
    ptname = DELSTR(ptraw, 1, ptr)
    IF ptr ~= 0 THEN DO /* need to seperate subdirectory and name */
        ptpath = DELSTR(ptraw, ptr)
    
        IF FontNameModeA = 1 THEN DO    /* fontname [path] */
            IF LENGTH(ptname) + LENGTH(ptpath) + 3 > path_chars_a THEN DO
                ptpath = "+" || RIGHT(ptpath, path_chars_a - (LENGTH(ptname) + 4))
                END
            ptlong = ptname || " [" || ptpath || "]"
            END
        ELSE DO /* path/fontname */
            IF LENGTH(ptname) + LENGTH(ptpath) + 1 > path_chars_a THEN DO
                ptpath = "+" || RIGHT(ptpath, path_chars_a - (LENGTH(ptname) + 2))
                END
            ptlong = ptpath || "/" || ptname
            END
        END
    ELSE DO /* there is no subdirectory - file is in main path */
        ptlong = ptname
        END

    ptleft = LEFT(ptlong, 37, ' ')  /* chop off at 37 chars - FW limit */

    block_vposition = TRUNC((row * offset_font_to_font) + tfont_margin) /* font v-pos */
    block_hposition = TRUNC((column * column_width) + left_margin) /* font left h-pos */

    TextBlockTypePrefs SIZE path_font_size WIDTH pf_width_a FONT path_font
    DrawTextBlock 1 block_hposition block_vposition ptleft
    GetObjectCoords RESULT

    IF LENGTH(ptlong) > 37 THEN DO  /* create and type right half if necessary */

        ptright = DELSTR(ptlong, 1, 37)

        Parse Var RESULT objpage objleft objtop objwidth objheight  /* get width of block */
        block2_hposition = TRUNC(block_hposition + objwidth) /* right half font h-pos */
        TextBlockTypePrefs SIZE path_font_size WIDTH pf_width_a FONT path_font
        DrawTextBlock 1 block2_hposition block_vposition ptright

        END

    END

block_vposition = TRUNC(block_vposition + offset_path_to_sample)
TextBlockTypePrefs SIZE sample_font_size WIDTH 100 FONT typewithpath
DrawTextBlock 1 block_hposition block_vposition TestString  /* draw sample of font */
GetObjectCoords RESULT
Parse Var RESULT objpage objleft objtop objwidth objheight  /* get width of block */

newstring = TestString /* make a copy of TestString to butcher up */
rdflag = 0  /* set flag 'screen has not been redrawn' */

DO WHILE objwidth > maxtswidth   /* an unusually wide font may need to be truncated */
    newstring = LEFT(newstring, LENGTH(newstring) - 1) /* lob a char off of string */ 
    IF rdflag = 0 THEN DO
        Redraw  /* deselect all but most recent object */
        rdflag = 1 /* don't redraw twice in a row */
        END
    Clear   /* erase only selected object (too wide) */
    DrawTextBlock 1 block_hposition block_vposition newstring /* draw new font sample */
    GetObjectCoords RESULT
    Parse Var RESULT objpage objleft objtop objwidth objheight /* get new block width */
    END

    /* filling columns at a time eases comparison of similarly named fonts */
row = row + 1   /* next row */
IF row >= max_rows THEN DO
    row = 0 
    column = column + 1 /* next column */
    IF column >= max_columns THEN DO
        row = 0
        column = 0
        CALL PRINTHEADER() /* end of page - type header on top of this page */
        CALL PAGEPRINT()   /* end of page - print it */
        page = page + 1
        CALL FWCLEAR()  /* clear FW document, set view, measure, pagesetup etc. */
        END
    END


RETURN

/* ########################################################################### */
/* ########################################################################### */

PAGEPRINT:  /* prompt user and print page */

Redraw      /* redraw page */
TextTool    /* de-select all graphics */

printmsg = '"Ready to print page ' || page || '"'
DO WHILE printed = 0

    IF pagepause = 1 then DO        /* display requester before next page */

        ADDRESS COMMAND 'Echo >CON:1/1/1/1' '07'X      /* ring bell through console */
        ADDRESS COMMAND 'RequestChoice >' FontFile || '.2' '" "' printmsg 'Print' '"Next pg"' '"Save as"' '"Autoprint"' 'Abort' 'PUBSCREEN' public_screen
        IF RC > 5 THEN DO   /* if error, retry without public screen */
            ADDRESS COMMAND 'RequestChoice >' FontFile || '.2' '" "' printmsg 'Print' '"Next pg"' '"Save as"' '"Autoprint"' 'Abort'
            IF RC > 5 THEN DO
                SAY "Can't run RequestChoice"
                EXIT 20
                END
            ScreenToFront   /* bring the Final Writer screen back to the front */
            END

        CALL OPEN('prtfile', FontFile || '.2', 'R')
        prtres = READLN('prtfile')
        CALL CLOSE('prtfile')
        ADDRESS COMMAND 'Delete >NIL: ' FontFile || '.2'

        IF prtres = 1 THEN DO
            Print    /* print page */
            printmsg = '"Print page ' || page || ' again?"'
            ITERATE /* give option to print again or save */
            END
        ELSE IF prtres = 4 THEN DO /* auto print - no page pause */
            Print    /* print page */
            autoprint = 1  /* 1 = automatically print pages */
            pagepause = 0   /* 0 = don't present requester to proceed printing */
            END
        ELSE IF prtres = 3 THEN DO
            SaveAs   /* bring up the 'save as' requester */
            ITERATE  /* back to previous menu */
            END
        ELSE IF prtres = 0 THEN DO /* abort */
            SAY "User abort"
            EXIT 5
            END
        ELSE NOP    /* prtres = 2 - go to next page */
        END

    ELSE IF autoprint = 1 then Print    /* print page automatically */

    printed = 1     /* exit loop by setting page printed flag */
    END

RETURN

/* ########################################################################### */
/* ########################################################################### */

FWCLEAR:    /* clear FW document, set view, measure, pagesetup etc. */

    ClearDoc "FORCE"  /* erase document - FIRST! */
    SetMeasure "Micropoints"  /* set FW measurement units to 1/720 on an inch */
    TextBlockPrefs "TEXTFLOW" "None"    /* set text block settings */

    SectionSetup "TOP" top_margin "Inside" header_margin "Outside" header_margin /* set page margin etc. */
    PageSetup "PAGETYPE" pagesize "Orient" "Tall"

    View viewsize

RETURN

/* ########################################################################### */
/* ########################################################################### */

PRINTHEADER:    /* print top two lines on page */

TextTool    /* text entry mode */
Justify "Center"
FontSize title_font_size
Font title_font
IF page_mode = 0 THEN DO
    Type TitleString0
    Type typepath
    END
ELSE DO
    Type TitleString1
    END

NewParagraph

stats1 = TRUNC((page - 1) * max_columns * max_rows + 1)
stats2 = TRUNC(fontcount + 1)

goodfonts = fontmax - badfonts

IF stats2 > goodfonts THEN stats2 = goodfonts   /* this is the max */ 

Type "page" page "of" pnum", fonts" stats1 "-" stats2

NewParagraph

RETURN

/* ########################################################################### */
/* ########################################################################### */

WRITEBADFONT:

IF badfonts = 0 THEN DO /* open a file for write on first bad font */
    CALL OPEN('badfontfile', bad_fonts_list, 'W')
    END

badfonts = badfonts + 1 /* increment count  - file must be closed at end */

CALL WRITELN('badfontfile', typewithpath)

IF badfontsreq = 1 THEN DO
    ShowMessage 1 0 '"Bad font:"' '"' || typewithpath || '"' '"" "Continue" "Do not ask again" "Abort"'
    IF Result = 3 THEN DO
        SAY "User abort"
        EXIT 5
        END
    ELSE IF Result = 2 THEN badfontsreq = 0 /* don't show message again */
    END

RETURN

/* ########################################################################### */
/* ########################################################################### */

IDENTIFY:   /* determine if files are fonts by matching leading ID bytes */
            /* write new list of fonts over old list of files */
            /* estimate count of fonts too */

IF ~OPEN('infile', FontFile, "R") THEN EXIT 10  /* verify files in FontFile */
IF ~OPEN('outfile', FontFile || '.id', "W") THEN EXIT 10  /* write font names here */

fontmax = 0   /* start estimated # of fonts at 0 */
DO WHILE ~EOF('infile')
    idfname = READLN('infile')
    IF ~OPEN('idfile', idfname, "R") THEN ITERATE  /* open file for read */
    idstr = READCH('idfile', 2)     /* read first 2 chars of this file */
    CALL CLOSE('idfile')    /* close the file - not needed anymore */
    IF idstr ~== fontid1 & idstr ~== fontid2 & idstr ~== fontid3 THEN ITERATE
    CALL WRITELN('outfile', idfname)    /* write valid font name/path */
    fontmax = fontmax + 1   /* increment estimated font count */
    END

CALL CLOSE('outfile')
CALL CLOSE('infile')

IF fontmax < 1 THEN CALL NOFONTS() /* error msg & quit */

ELSE DO
    ADDRESS COMMAND 'Delete >NIL: ' FontFile /* replace old list w/ id'd list */
    ADDRESS COMMAND 'Rename >NIL: ' FontFile || '.id' FontFile
    END

RETURN

/* ########################################################################### */
/* ########################################################################### */

NOFONTS:   /* present "no fonts" error message and quit */

statsl1 = '"' || "Fontaloger:" || '"'                   /* assemble line 1 text */
statsl2 = '"' || "There were no fonts found" || '"'     /* assemble line 2 text */
statsl3 = '"' || "in the specified path." || '"'        /* assemble line 3 text */
ShowMessage 1 0 statsl1 statsl2 statsl3 '"Abort" "" ""'
SAY "No fonts in specified path."

EXIT 10

RETURN  /* not really */

/* ########################################################################### */
/* ########################################################################### */

FSORT:   /* sort fonts by path+name or by name first, then path */

IF sort_mode = 1 THEN DO    /* sort fonts by name first, then path */

    IF ~OPEN('infile', FontFile, "R") THEN EXIT 10  /* read font filenames from FontFile */
    IF ~OPEN('outfile', FontFile || '.3', "W") THEN EXIT 10  /* sort formatted fnames here */

    DO FOREVER
        nsfname = READLN('infile')
        ptr = LASTDIR(nsfname)    /* find last occurrance of '/' or ':' */
        nsname = DELSTR(nsfname, 1, ptr)
        nspath = DELSTR(nsfname, ptr)
        nsout = nsname || '?' || nspath /* add '?' to mark division */
        IF ~EOF('infile') THEN CALL WRITELN('outfile', nsout)  /* write valid font name/path */
        ELSE BREAK
        END

    CALL CLOSE('outfile')
    CALL CLOSE('infile')

    ADDRESS COMMAND 'Sort FROM ' || FontFile || '.3' 'TO' FontFile || '.3'

    IF ~OPEN('infile', FontFile || '.3', "R") THEN EXIT 10  /* read sorted filenames */
    IF ~OPEN('outfile', FontFile, "W") THEN EXIT 10  /* reformatted fnames here */

    DO FOREVER
        nsfname = READLN('infile')
        ptr = INDEX(nsfname, '?')    /* find (only) occurrance of '?' */
        nsname = DELSTR(nsfname, ptr)
        nspath = DELSTR(nsfname, 1, ptr)
        nsout = nspath || '/' || nsname /* return list to normal path format */
        IF ~EOF('infile') THEN CALL WRITELN('outfile', nsout)  /* write valid font name/path */
        ELSE BREAK
        END

    CALL CLOSE('outfile')
    CALL CLOSE('infile')

    ADDRESS COMMAND 'Delete >NIL: ' FontFile || '.3'    /* delete temp sort file */

    END

ELSE DO /* do simple path+name sort */

    ADDRESS COMMAND 'Sort FROM' FontFile 'TO' FontFile

    END

RETURN

/* ########################################################################### */
/* ########################################################################### */

LASTDIR: PROCEDURE  /* return pointer to last occurance of '/' or ':' in a string */
                    /* ...yes, a real live PROCEDURE in my code... */

ARG pstring

ptr = LASTPOS('/', pstring)                 /* find last occurrance of '/' */
IF ptr = 0 THEN ptr = LASTPOS(':', pstring) /* find last occurrance of ':' */

RETURN ptr

/* ########################################################################### */
/* ########################################################################### */

GETCONFIG: /* things you might want to mess with  */

ask_everything = 1  
    /* 1 = ask max_columns, autoprint, pagepause, listtofile, 0 = use defaults (below) */
    max_columns = 1 /* default: one, two, or three columns for font samples */
    autoprint = 0   /* default: 1 = print pages, 0 = print if told to at pg pause */
    pagepause = 1   /* default: 1 = present requester when ready to print/save */
    listtofile = 0  /* default: 1 = list all fonts to a file in RAM Disk */

sort_mode = 0   /* 1 = sort by font name, then path, 0 = by path+name */
page_mode = 0   /* 1 = full font path for each font, 0 = path in header */
badfontsreq = 1 /* display an option to abort on bad font */
pagesize = "USLetter"   /* pagetype */
viewsize = 75   /* page size % (magnification) */
public_screen = "FinalWriterPubScreen"  /* screen for non-FW requesters */
bad_fonts_list = "RAM:BadFontsList"     /* fonts that would not load */
FontFile = "T:FontalogerTemp"
FontList = "RAM:FontList"
TestString = "AaBbCcXxYyZz1234567890"   /* sample characters printed for each font */ 
TitleString0 = "Font listing of "   /* Title for page-mode = 0 */
TitleString1 = "Fontaloger font listing"   /* Title for page-mode = 1 */
FontNameModeA = 0   /* page format 'A': 0 = "path/fontname", 1 = "fontname [path]" */
FontNameModeB = 1   /* page format 'B': 0 = "path/fontname", 1 = "fontname [path]" */
autoid = 1  /* default to include this option in the font pattern requester */

fontid1 = '0014'X   /* font ID header - FW stock */
fontid2 = '8001'X   /* font ID header - Adobe Type 1 */
fontid3 = '0F03'X   /* font ID header - AGFA */

RETURN

/* ########################################################################### */
/* ########################################################################### */

GETLAYOUT: /* more stuff you might want to mess with */

IF max_columns = 1 THEN DO
    top_margin = TRUNC(.5 * mpi)    /* blank area on top of page */
    bottom_margin = TRUNC(.7 * mpi) /* blank area on bottom of page */
    left_margin = TRUNC(.9 * mpi)   /* blank area on left edge of page */
    right_margin = TRUNC(.3 * mpi)  /* blank area on right edge of page */
    header_space = TRUNC(.9 * mpi)  /* space allowed for page header */
    header_margin = TRUNC(.5 * mpi) /* left and right margin for text entry */
    offset_path_to_sample = (mpi * .34) /* vertical offset of path and font sample */
    offset_font_to_font = (mpi * .58)   /* vertical offset of sequential font sample groups */
    title_font = "SoftSans"
    title_font_size = 12
    path_font = "Courier"
    path_font_size = 18
    pf_width_a = 100    /* applies only to page format 'A' */
    pf_width_b = 60     /* applies only to page format 'B' */
    path_chars_a = 45   /* NO GREATER THAN 74! - max chars in mode 'A' path/name line */
    path_chars_b = 74   /* NO GREATER THAN 74! - max chars in mode 'B' name [path] */
    sample_font_size = 28
    max_rows = "auto"   /* number of rows of fonts on a page - or "auto" */
    END
ELSE IF max_columns = 2 THEN DO
    top_margin = TRUNC(.5 * mpi)    /* blank area on top of page */
    bottom_margin = TRUNC(.7 * mpi) /* blank area on bottom of page */
    left_margin = TRUNC(.75 * mpi)  /* blank area on left edge of page */
    right_margin = TRUNC(.3 * mpi)  /* blank area on right edge of page */
    header_space = TRUNC(.65 * mpi) /* space allowed for page header */
    header_margin = TRUNC(.5 * mpi) /* left and right margin for text entry */
    offset_path_to_sample = (mpi * .19) /* vertical offset of path and font sample */
    offset_font_to_font = (mpi * .32)   /* vertical offset of sequential font sample groups */
    title_font = "SoftSans"
    title_font_size = 12
    path_font = "Courier"
    path_font_size = 9
    pf_width_a = 100    /* applies only to page format 'A' */
    pf_width_b = 60     /* applies only to page format 'B' */
    path_chars_a = 45   /* NO GREATER THAN 74! - max chars in mode 'A' path/name line */
    path_chars_b = 74   /* NO GREATER THAN 74! - max chars in mode 'B' name [path] */
    sample_font_size = 15
    max_rows = "auto"   /* number of rows of fonts on a page - or "auto" */
    END
ELSE DO /* max_columns = 3 */
    top_margin = TRUNC(.5 * mpi)    /* blank area on top of page */
    bottom_margin = TRUNC(.7 * mpi) /* blank area on bottom of page */
    left_margin = TRUNC(.75 * mpi)  /* blank area on left edge of page */
    right_margin = TRUNC(.3 * mpi)  /* blank area on right edge of page */
    header_space = TRUNC(.65 * mpi) /* space allowed for page header */
    header_margin = TRUNC(.5 * mpi) /* left and right margin for text entry */
    offset_path_to_sample = (mpi * .13) /* vertical offset of path and font sample */
    offset_font_to_font = (mpi * .25)   /* vertical offset of sequential font sample groups */
    title_font = "SoftSans"
    title_font_size = 12
    path_font = "Courier"
    path_font_size = 6
    pf_width_a = 100    /* applies only to page format 'A' */
    pf_width_b = 60     /* applies only to page format 'B' */
    path_chars_a = 45   /* NO GREATER THAN 74! - max chars in mode 'A' path/name line */
    path_chars_b = 74   /* NO GREATER THAN 74! - max chars in mode 'B' name [path] */
    sample_font_size = 10
    max_rows = "auto"   /* number of rows of fonts on a page - or "auto" */
    END

RETURN

/* ########################################################################### */
/* ########################################################################### */