HTMLSTREAM

(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)


(FILECREATED "25-Mar-2026 15:59:44" {HTMLSTREAM}HTMLSTREAM.;97
 108959 

      :CHANGES-TO (FUNCTIONS HTML.CREATE-ALL-MEDLEYFONT-FAMILIES HTML.FONT HTML.COLOR HTML.BACKCOLOR
                         HTML.LINEFEED \HTML.FONTCREATE \HTML.TOADDR HTMLFONT.GETCHARSET 
                         HTML.OUTPUT-TEXT HTML.WRITE-PREFACE HTML.MOVETO HTML.XPOSITION)
                  (VARIABLES *HTML-STYLESHEET-FONT-FAMILY-DEFS* HTMLCHARSETFNS *WEB-FONT-FAMILIES* 
                         *HTML-STANDARD-PAGE-WEB-FONT-FAMILIES* *WEB-FONT-FAMILY-NAMES* 
                         *BROWSER-FONTS-MAP*)
                  (STRUCTURES HTML.FONTINFO)

      :PREVIOUS-DATE "25-Feb-2026 13:53:32" {HTMLSTREAM}HTMLSTREAM.;92)


(PRETTYCOMPRINT HTMLSTREAMCOMS)

(RPAQQ HTMLSTREAMCOMS

       ((FILES BASE64 U-PNG)
        
        (* ;; "handy macros and functions")


        (FUNCTIONS DO-NOT \HTML-DBG \HTML.TOADDR)
        (VARIABLES *CENTIPOINTS-PER-POINT* TAB-WIDTH-IN-CHARACTERS)
        (RECORDS WEB-FONT-DESCR WEB-FONT-FACE WEB-FONT-METRICS WEB-CHARSET-METRICS)
        (FUNCTIONS CLOSE-KNOTS HTML.INCHES-TO-POINTS HTML.INCHES-TO-CENTIPOINTS CP-TO-P ICP-TO-P 
               P-TO-CP PIXEL-TO-PT PT-TO-PIXEL \SF \HTML.SVG-Y)
        (FUNCTIONS INSURE-COLOR-OR-SHADE)
        (FUNCTIONS MAKE-FONT-METRICS-FILE-NAME MAKE-CHARSET-METRICS-FILE-NAME)
        (VARIABLES *WEB-FONT-MAPPINGS* HTMLFONTCOERCIONS HTMLFONTDIRECTORIES HTMLFONTEXTENSIONS 
               HTMLCHARSETFNS *GOOGLE-FONTS-BASE-URL* *HTML-STANDARD-PAGE-WEB-FONT-FAMILIES* 
               *HTML-STYLESHEET-FONT-FAMILY-DEFS* *DEFAULT-WEB-FONT-METRICS-FILE-NAME* 
               *WEB-FONT-EXPANSIONS* *WEB-FONT-FAMILIES* *WEB-FONT-FAMILY-NAMES* *WEB-FONT-SIZES* 
               *WEB-FONT-SLOPES* *WEB-FONT-WEIGHTS* *BROWSER-FONTS-MAP* *WEB-CHARSET-METRICS-EXT* 
               *WEB-CHARSET-METRICS-DOT-EXT* *WEB-FONT-METRICS-EXT* *WEB-FONT-METRICS-DOT-EXT* 
               *HTML-ADD-FONT-DEFS*)
        (VARIABLES *BROWSER-FONT-FILE-VERSION* *HTML.DEFAULT-PAGE-REGION* HTML.FONTCREATE.DEVICENAME
               HTML.IMAGETYPE HTML.STATE.BETWEEN-PAGES HTML.STATE.CLOSED HTML.STATE.NON-TEXT 
               HTML.STATE.NON-TEXT-OUTPUT HTML.STATE.TEXT-OUTPUT HTML.STATES \HTMLSTREAM.FDEV 
               *XCCS-KNOWN-CHARSETS* *XCCS-UNDEFINED-CHARCODE* HTML-MEDLEY-CREDITS)
        (FUNCTIONS HTML-FONT-METRICS-VERSION-OK? CHECK-BROWSER-METRICS-FORMAT CSS-CLASS-FROM 
               CSS-CLASS-FROM-FAMILY \HTML.READ-FONT-METRICS \HTML.READ-CHARSET-METRICS 
               \HTML.SVG-STROKE-DASHARRAY \HTML.SVG-BRUSH-WIDTH \HTML.SVG-BRUSH-CLASS \HTML.SVG-COLOR
               )
        (STRUCTURES HTML.IMAGEDATA HTML.FONTINFO)
        (FUNCTIONS with-htmldata)
        (FUNCTIONS HTML.OUTPUT-GRAPHICS HTML.OUTPUT-TEXT \HTML.MAYBE-START-PAGE \HTML.END-PAGE 
               \HTML.TAB-DELTA-X \HTML.CHARWIDTH HTML.WRITE-PREFACE CONVERT-FAMILY-TO-QUERY-PARAM 
               \HTML.MAKE-STYLESHEET-URL)
        (FUNCTIONS OPENHTMLSTREAM HTML.BACKCOLOR HTML.BITBLT HTML.BLTSHADE HTML.BOTTOMMARGIN 
               HTML.CHARWIDTH HTML.CLIPPINGREGION HTML.CLOSEFN HTML.COLOR HTML.DRAWCIRCLE 
               HTML.DRAWCURVE HTML.DRAWELLIPSE HTML.DRAWLINE HTML.DRAWPOLYGON HTML.DRAWARC 
               HTML.FILLCIRCLE HTML.FILLPOLYGON HTML.FONT HTML.LEFTMARGIN HTML.LINEFEED HTML.MOVETO 
               HTML.NEWPAGE HTML.OPERATION HTML.OUTCHARFN HTML.RESET HTML.RIGHTMARGIN HTML.SCALE 
               HTML.SCALEDBITBLT HTML.SPACEFACTOR HTML.TERPRI HTML.TOPMARGIN HTML.XPOSITION 
               HTML.YPOSITION MAKE-HTML-IMAGETYPE \HTML.INIT-IMAGEDATA \HTMLSTREAM.INIT)
        (FUNCTIONS WRITE-BASE64-PNG CONVERT-TO-PNG-BASE64)
        (FUNCTIONS URL-ENCODE HTML-ENCODE)
        (VARIABLES *HTML-DEBUG-FONTCREATE*)
        (VARIABLES *HTML-FONT-METRIC-BASIS*)
        (FUNCTIONS \HTML.FONTCREATE \HTML.FONTEXISTS? \HTML.FONTSAVAILABLE HTMLFONT.GETCHARSET 
               HTMLFONT.FILEP \HTML.CREATECHARSET \HTML.CHANGECHARSET MAKE-CHARSET-BIT-ARRAY 
               KNOWN-CHARSET? \HTML.WARN-CHARSET \HTML.ADD-FONT-DEFS \FIRST-COERCION 
               \HTML.COERCE-OR-IDENTITY \HTML.COERCE-FONT MAYBE-MARK-FONT-COMPLETE)
        
        (* ;; "New Font World!")


        (FUNCTIONS \HTML.FONTCREATE-NEW)
        (P (\HTMLSTREAM.INIT))
        
        (* ;; "MEDLEYFONT-related utility")


        (VARIABLES *HTML.ALL-GENERATED-FONT-SIZES* *HTML.ALL-GENERATED-FONT-FACES*)
        (FUNCTIONS HTML.CREATE-MEDLEYFONT-FAMILY HTML.CREATE-ALL-MEDLEYFONT-FAMILIES)
        
        (* ;; "PRINTFILETYPES-related")


        (VARIABLES *HTML-FILE-EXTENSIONS* *HTML-FINGERPRINTS*)
        (FUNCTIONS HTMLFILEP MAKE-HTML-FROM-TEXT MAKE-HTML-FROM-TEDIT)
        (ADDVARS [PRINTFILETYPES (HTML (TEST HTMLFILEP)
                                       (EXTENSION (HTML))
                                       (CONVERSION (TEXT MAKE-HTML-FROM-TEXT TEDIT 
                                                         MAKE-HTML-FROM-TEDIT]
               (FB.SEE.METHODS (HTMLFILEP ShellOpen)))
        
        (* ;; "debugging support")


        (FUNCTIONS \CLEAN-FONT-CACHE)))

(FILESLOAD BASE64 U-PNG)



(* ;; "handy macros and functions")



(DEFMACRO DO-NOT
 (&BODY BODY)
   "Ignore the body, return NIL"
   NIL)

(DEFMACRO \HTML-DBG
 (&REST REST)
   "Produce HTML/font-related debug info if enabled"
   `(CL:WHEN *HTML-DEBUG-FONTCREATE*
        (CL:FORMAT T ,@REST)))

(CL:DEFUN \HTML.TOADDR
 (X)
   "Convert the object to a string made from its address"
   (CL:FORMAT NIL "~a/~o,~o" (TYPENAME X)
          (\HILOC X)
          (\LOLOC X)))

(CL:DEFCONSTANT *CENTIPOINTS-PER-POINT*
 100
   "There are 100 centipoints per point, by definition and by golly!")

(CL:DEFCONSTANT TAB-WIDTH-IN-CHARACTERS
 8
   "A TAB character will move this many characters")
(DECLARE%: EVAL@COMPILE

(PROPRECORD WEB-FONT-DESCR
 (:NAME :FACE :SIZE :HEIGHT :SLUG-WIDTH :MAX-ASCENT :MAX-DESCENT :CHARSETS))

(RECORD WEB-FONT-FACE
 (:WEIGHT :SLOPE :EXPANSION))

(PROPRECORD WEB-FONT-METRICS
 (:FAMILY :SIZE :WEIGHT :STYLE :HEIGHT :MAX-ASCENT :MAX-DESCENT :CHARSETS
                                    :LISP-NAME :LISP-FACE :LISP-SIZE))

(PROPRECORD WEB-CHARSET-METRICS
 (:CHARSET :MAX-ASCENT :MAX-DESCENT :WIDTHS))
)

(CL:DEFUN CLOSE-KNOTS
 (KNOTS)
   "Create a closed polygon by adding the first point to the end of the list"
   (LET ((FIRST-KNOT (CAR KNOTS)))
        (APPEND KNOTS (LIST FIRST-KNOT))))

(CL:DEFUN HTML.INCHES-TO-POINTS
 (INCHES)
   "Convert inches to points"

   (* ;; "Assume one inch contains 72 points")


   (FIXR (TIMES 72 INCHES)))

(CL:DEFUN HTML.INCHES-TO-CENTIPOINTS
 (INCHES)
   (FIXR (TIMES 72 *CENTIPOINTS-PER-POINT* INCHES)))

(DEFMACRO CP-TO-P
 (CENTIPOINTS)
   `(FQUOTIENT ,CENTIPOINTS *CENTIPOINTS-PER-POINT*))

(DEFMACRO ICP-TO-P
 (CENTIPOINTS)

   (* ;; "convert centipoints to an integer number of points")


   `(FIXR (FQUOTIENT ,CENTIPOINTS *CENTIPOINTS-PER-POINT*)))

(DEFMACRO P-TO-CP
 (POINTS)
   `(FTIMES ,POINTS *CENTIPOINTS-PER-POINT*))

(CL:DEFUN PIXEL-TO-PT
 (PIXELS)
   "Convert some number of pixels to that number of points"

   (* ;; "96 pixels = 72 points")


   (FTIMES 0.75 PIXELS))

(CL:DEFUN PT-TO-PIXEL
 (POINTS)
   "Convert some number of points to that number of pixels"

   (* ;; "96 pixels = 72 points")


   (FTIMES 1.333 POINTS))

(DEFMACRO \SF
 (FONT-NAME)
   "Marker for a font name substituting for another"
   FONT-NAME)

(CL:DEFUN \HTML.SVG-Y
 (DATA MEDLEY-Y)
   "Return the SVG Y-coordinate for a Medley Y coordinate"
   (- (\HTML-PAGE-HEIGHT DATA)
      MEDLEY-Y))

(CL:DEFUN INSURE-COLOR-OR-SHADE
 (COLOR)
   "Insure that the COLOR argument is a valid color or gray shade"

   (* ;; "Use INSURE.RGB.COLOR for colors.  Scalars 0 <= x <= 1 are gray shades.")


   (* ;; "This is based on the logic in \PSC.COLOR.TO.RGB.")


   (COND
      ((OR (EQ COLOR 0)
           (EQ COLOR 1)
           (AND (FLOATP COLOR)
                (<= 0.0 COLOR 1.0)))                         (* ; "convert to an RGB triple")

       (LET [(GRAY (FIXR (TIMES 255 COLOR]
            (LIST GRAY GRAY GRAY)))
      (T (INSURE.RGB.COLOR COLOR))))

(CL:DEFUN MAKE-FONT-METRICS-FILE-NAME
 (FAMILY SIZE WEIGHT SLOPE EXPANSION)
   "Create the name of the file that holds the metrics for the given font"

   (* ;; "The file name looks like <family>-<size>-<weightChar><slopeChar><expansionChar>.wfm")


   (LET [(FACE-ABBREV (L-CASE (FONTFACETOATOM (create
 FONTFACE
                                                     WEIGHT _ WEIGHT
                                                     SLOPE _ SLOPE
                                                     EXPANSION _ EXPANSION]
        (CL:FORMAT NIL "~A-~d-~A.~A" FAMILY SIZE FACE-ABBREV *WEB-FONT-METRICS-EXT*)))

(CL:DEFUN MAKE-CHARSET-METRICS-FILE-NAME
 (FAMILY SIZE WEIGHT SLOPE EXPANSION CHARSET-NUM)
   "Create the name of the file that holds the metrics for the given charset"

   (* ;; "The file name looks like c<octalCharset>'><family><size>-<weightChar><slopeChar><expansionChar>-c<octalCharset>.wcm")


   (* ;; "e.g.,")


   (* ;; "c0>NOTO-SANS10-MRR-c0.wcm")


   (LET [(FACE-ABBREV (L-CASE (FONTFACETOATOM (create
 FONTFACE
                                                     WEIGHT _ WEIGHT
                                                     SLOPE _ SLOPE
                                                     EXPANSION _ EXPANSION]
        (CL:FORMAT NIL "c~o>~A~d-~A-c~o.~A" CHARSET-NUM FAMILY SIZE FACE-ABBREV CHARSET-NUM 
               *WEB-CHARSET-METRICS-EXT*)))

(DEFGLOBALVAR *WEB-FONT-MAPPINGS*

   '((HELVETICA . NOTO-SANS)
     (HELVETICAD . NOTO-SANS-DISPLAY)
     (TIMESROMAN . NOTO-SERIF)
     (TIMESROMAND . NOTO-SERIF-DISPLAY)
     (COURIER . NOTO-SANS-MONO)
     (GACHA . NOTO-SANS-MONO)
     (CLASSIC . NOTO-SERIF)
     (MODERN . NOTO-SANS)
     (CREAM . NOTO-SANS)
     (TERMINAL . NOTO-SANS-MONO)
     (LOGO . NOTO-SANS-MONO)
     (OPTIMA . NOTO-SERIF)
     (TITAN . NOTO-SANS-MONO))
   "Map common font families to Web font families")

(CL:DEFPARAMETER HTMLFONTCOERCIONS

   '[(HELVETICA NOTO-SANS)
     (HELVETICAD NOTO-SANS-DISPLAY)
     (TIMESROMAN NOTO-SERIF)
     (TIMESROMAND NOTO-SERIF-DISPLAY)
     (COURIER NOTO-SANS-MONO)
     (GACHA NOTO-SANS-MONO)
     (CLASSIC NOTO-SERIF)
     (MODERN NOTO-SANS)
     (CREAM NOTO-SANS)
     (TERMINAL NOTO-SANS-MONO)
     (LOGO NOTO-SANS-MONO)
     (OPTIMA NOTO-SERIF)
     (TITAN NOTO-SANS-MONO)
     (                                                       (* (<= * 5))

                                                             (* 6)

      )
     (                                                       (* (<= 51 * 91))

                                                             (* 50)

      )
     (                                                       (* (< 92 *))

                                                             (* 92)

      )
     (                                                       (* (ODDP *))

                                                             (* (ADD1 *))

      ]
   "Font coercion rules for COERCEFONTSPEC")

(CL:DEFVAR HTMLFONTDIRECTORIES
 '(".")
                               "The directory that holds .wfm and .wcm files")

(CL:DEFPARAMETER HTMLFONTEXTENSIONS
 '("medleyhtmlfont" "wcm")
                                    "The extensions that identify HTML font metrics files")

(CL:DEFPARAMETER HTMLCHARSETFNS
 (LET [(ORIGINAL
 '((MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET)
                                                  (HTMLFONT HTMLFONT.FILEP HTMLFONT.GETCHARSET]
                                     (CDR ORIGINAL))

                                (* ;; 

                   "%"comment out%" the MEDLEYFONT support, which was smashing the CSS-CLASS somehow")


                                "HTML charset functions. Ignore MEDLEYFONT for now.")

(CL:DEFVAR *GOOGLE-FONTS-BASE-URL*
 "https://fonts.googleapis.com/css2"
   "The base of the Google Fonts font stylesheet URL")

(CL:DEFPARAMETER *HTML-STANDARD-PAGE-WEB-FONT-FAMILIES*
 '(NOTO-SANS NOTO-SANS-MONO NOTO-SANS-DISPLAY
                                                                NOTO-SERIF NOTO-SERIF-DISPLAY)

                                                        (* ;; 

                       "these correspond to the property names in *HTML-STYLESHEET-FONT-FAMILY-DEFS*")


                                                        
                  "The names of the standard font families to be included in the HTML pages we write")

(CL:DEFPARAMETER *HTML-STYLESHEET-FONT-FAMILY-DEFS*

   `(NOTO-SANS ("Noto Sans" "Noto Sans TC" "Noto Sans JP" "Noto Sans KR" "Noto Sans Arabic" 
                      "Noto Sans Hebrew" "Noto Sans Runic" "Noto Sans Georgian" "Noto Sans Armenian"
                      "Noto Sans Thai" "Noto Sans Lao" "Noto Sans Gurmukhi" "Noto Sans Bengali" 
                      "Noto Sans Coptic" "Noto Sans Javanese" "Noto Sans Math" "Noto Sans Symbols" 
                      "Noto Sans Symbols 2" "Noto Emoji")
           NOTO-SANS-MONO
           ("Noto Sans Mono")
           NOTO-SANS-DISPLAY
           ("Noto Sans Display")
           NOTO-SERIF
           ("Noto Serif" "Noto Serif TC" "Noto Serif JP" "Noto Serif KR" "Noto Naskh Arabic" 
                  "Noto Serif Hebrew" ,(\SF
 "Noto Sans Runic")
                  "Noto Serif Georgian" "Noto Serif Armenian" "Noto Serif Thai" "Noto Serif Lao" 
                  "Noto Serif Devanagari" "Noto Serif Gurmukhi" "Noto Serif Bengali"
                  ,(\SF
 "Noto Sans Coptic")
                  ,(\SF
 "Noto Sans Javanese")
                  ,(\SF
 "Noto Sans Math")
                  ,(\SF
 "Noto Sans Symbols")
                  ,(\SF
 "Noto Sans Symbols 2")
                  "Noto Emoji")
           NOTO-SERIF-DISPLAY
           ("Noto Serif Display"))
   "The font family styles we'll load into the page. Sync with FontStackDefinitions.")

(CL:DEFCONSTANT *DEFAULT-WEB-FONT-METRICS-FILE-NAME*
 "font-metrics.data"
   "The usual name of the raw font metrics file we get from the browser")

(CL:DEFCONSTANT *WEB-FONT-EXPANSIONS*
 '(REGULAR)
                                      "The Web font expansions we support")

(CL:DEFCONSTANT *WEB-FONT-FAMILIES*
 '((NOTO-SANS . "ns")
                                      (NOTO-SANS-MONO . "nsm")
                                      (NOTO-SANS-DISPLAY . "nsd")
                                      (NOTO-SERIF . "nsf")
                                      (NOTO-SERIF-DISPLAY . "nsfd"))
                                    
                              "A-list of supported Web font names, as atoms, with the CSS class name")

(CL:DEFCONSTANT *WEB-FONT-FAMILY-NAMES*
 '("Noto Sans" "Noto Sans Mono" "Noto Sans Display" 
                                                "Noto Serif" "Noto Serif Display")

                                        (* ;; "keep this synchronized with *WEB-FONT-FAMILIES*")


                                        
                               "The names of the font families we're using, suitable for use in CSS.")

(CL:DEFCONSTANT *WEB-FONT-SIZES*

   '(6 8 10 12 14 16 18 20 24 32 34 36 38 40 42 44 46 48 50 92)
   "Sizes of the Web fonts we support, in points"

   (* ;; "Keep this in sync with WebFontMetrics.Main.FONT_SIZES")


   )

(CL:DEFCONSTANT *WEB-FONT-SLOPES*
 '(REGULAR ITALIC)
                                  "The Web font slopes we support")

(CL:DEFCONSTANT *WEB-FONT-WEIGHTS*
 '(MEDIUM BOLD)
                                   "The supported Web font weights")

(CL:DEFPARAMETER *BROWSER-FONTS-MAP*
 '((NOTO-SANS . "sans-serif")
                                       (NOTO-SANS-MONO . "monospace")
                                       (NOTO-SANS-DISPLAY . "sans-serif")
                                       (NOTO-SERIF . "serif")
                                       (NOTO-SERIF-DISPLAY . "serif"))
                                     
     "Map each of our fonts to a browser default. The metrics for these characters may be incorrect.")

(CL:DEFCONSTANT *WEB-CHARSET-METRICS-EXT*
 "wcm"
   "The filename extension for files that describe a charset's metrics")

(CL:DEFCONSTANT *WEB-CHARSET-METRICS-DOT-EXT*
 (CONCAT "." *WEB-CHARSET-METRICS-EXT*)
                                              
       "The filename extension for files that describe a charset's metrics, prepended with a dot (.)")

(CL:DEFCONSTANT *WEB-FONT-METRICS-EXT*
 "wfm"
   "The file extension for a web font metrics file")

(CL:DEFCONSTANT *WEB-FONT-METRICS-DOT-EXT*
 (CONCAT "." *WEB-FONT-METRICS-EXT*)
                                           
                           "The file extension for a web font metrics file, prepended with a dot (.)")

(CL:DEFVAR *HTML-ADD-FONT-DEFS*
 T
   "Initialize font defs and font vars upon loading HTMLSTREAM?")

(CL:DEFCONSTANT *BROWSER-FONT-FILE-VERSION*
 3
   "The current version of the font-metrics.data file")

(CL:DEFCONSTANT *HTML.DEFAULT-PAGE-REGION*


   (* ;; "the default region of an HTML page, in centipoints")


   (create
 REGION
          LEFT _ 0
          BOTTOM _ 0
          WIDTH _ (HTML.INCHES-TO-CENTIPOINTS
 8.5)
          HEIGHT _ (HTML.INCHES-TO-CENTIPOINTS
 11.0)))

(CL:DEFCONSTANT HTML.FONTCREATE.DEVICENAME
 'HTML)

(CL:DEFCONSTANT HTML.IMAGETYPE
 'HTML)

(CL:DEFCONSTANT HTML.STATE.BETWEEN-PAGES
 :HTML.STATE.BETWEEN-PAGES)

(CL:DEFCONSTANT HTML.STATE.CLOSED
 :HTML.STATE.CLOSED)

(CL:DEFCONSTANT HTML.STATE.NON-TEXT
 :HTML.STATE.NON-TEXT)

(CL:DEFCONSTANT HTML.STATE.NON-TEXT-OUTPUT
 :HTML.STATE.NON-TEXT-OUTPUT)

(CL:DEFCONSTANT HTML.STATE.TEXT-OUTPUT
 :HTML.STATE.TEXT-OUTPUT)

(CL:DEFCONSTANT HTML.STATES
 '(HTML.STATE.BETWEEN-PAGES HTML.STATE.NON-TEXT-OUTPUT 
                                    HTML.STATE.TEXT-OUTPUT HTML.STATE.CLOSED)
                            "All HTML imagestream states, for informational use.")

(DEFGLOBALVAR \HTMLSTREAM.FDEV
 "The FDEV for HTML output")

(CL:DEFCONSTANT *XCCS-KNOWN-CHARSETS*

   '(0 33 34 35 36 37 38 39 40 224 225 226 227 228 238 239 240 241)
   "The set of defined XCCS character sets")

(CL:DEFCONSTANT *XCCS-UNDEFINED-CHARCODE*
 61639
   "XCCS defines 0xF0C7 (61639) as 'Replacement symbol (for undefined code points)'")

(CL:DEFCONSTANT HTML-MEDLEY-CREDITS

   "<!-- Created by Medley Interlisp software. Details at interlisp.org. -->~%%"
   "Embed this at the start of every HTML document. Contents must respect the rules for HTML/XML comments."
)

(CL:DEFUN HTML-FONT-METRICS-VERSION-OK?
 (VERSION-EXPR)
   "Return T if VERSION-EXPR is a valid font or charset version expression"
   (AND (LISTP VERSION-EXPR)
        (EQ ':FORMAT (CAR VERSION-EXPR))
        (EQUAL (CADR VERSION-EXPR)
               *BROWSER-FONT-FILE-VERSION*)))

(CL:DEFUN CHECK-BROWSER-METRICS-FORMAT
 (VERSION)

   (* ;; "check that the version looks like (format <number>)")


   (if
 (NOT (HTML-FONT-METRICS-VERSION-OK?
 VERSION))
       then
 (ERROR "File does not begin with expected format declaration" VERSION))
   VERSION)

(CL:DEFUN CSS-CLASS-FROM
 (FAMILY SIZE FACE)
   "Compute the CSS class names from the FAMILY, SIZE, and FACE"

   (* ;; "the result will look like %"nsd10 bold italic%" or a variant")


   [LET* [(FONT-CLASS-NAME-ROOT (CDR (FASSOC FAMILY *WEB-FONT-FAMILIES*)))
          (SIZE-CLASS-NAME (CONCAT "sz" SIZE))
          (WEIGHT-CLASS (COND
                           ((EQ (CAR FACE)
                                'BOLD)
                            "bold")
                           (T NIL)))
          (SLOPE-CLASS (COND
                          ((EQ (CADR FACE)
                               'ITALIC)
                           "italic")
                          (T NIL)))
          (SLOPE-AND-WEIGHT-CLASSES (COND
                                       ((AND (NULL WEIGHT-CLASS)
                                             (NULL SLOPE-CLASS))
                                        "")
                                       ((NULL WEIGHT-CLASS)
                                        SLOPE-CLASS)
                                       ((NULL SLOPE-CLASS)
                                        WEIGHT-CLASS)
                                       (T (CONCAT WEIGHT-CLASS " " SLOPE-CLASS]
         (CONCAT FONT-CLASS-NAME-ROOT " " SIZE-CLASS-NAME (COND
                                                             ((EQUAL SLOPE-AND-WEIGHT-CLASSES "")
                                                              "")
                                                             (T (CONCAT " " SLOPE-AND-WEIGHT-CLASSES])

(CL:DEFUN CSS-CLASS-FROM-FAMILY
 (FAMILY)
   "Compute the CSS class name from the FAMILY"
   (CDR (FASSOC FAMILY *WEB-FONT-FAMILIES*)))

(CL:DEFUN \HTML.READ-FONT-METRICS
 (FAMILY FACE SIZE DIR)
   "Read the font metrics file and return the WEB-FONT-DESCR"
   (LET* ((WEIGHT (fetch
 (WEB-FONT-FACE :WEIGHT) of
 FACE))
          (SLOPE (fetch
 (WEB-FONT-FACE :SLOPE) of
 FACE))
          (EXPANSION (fetch
 (WEB-FONT-FACE :EXPANSION) of
 FACE))
          (FILE-NAME (PACKFILENAME.STRING 'DIRECTORY DIR 'NAME (MAKE-FONT-METRICS-FILE-NAME
 FAMILY 
                                                                      SIZE WEIGHT SLOPE EXPANSION)))
          (*PACKAGE* (CL:FIND-PACKAGE "IL")))
         (CL:WITH-OPEN-STREAM (IN
 (OPENSTREAM FILE-NAME 'INPUT))
                (CHECK-BROWSER-METRICS-FORMAT
 (READ IN))
                (LET* ((DESCR (READ IN))
                       (FAMILY (fetch
 (WEB-FONT-DESCR :NAME) of
 DESCR))
                       (FACE (fetch
 (WEB-FONT-DESCR :FACE) of
 DESCR))
                       (SIZE (fetch
 (WEB-FONT-DESCR :SIZE) of
 DESCR))
                       (HEIGHT (fetch
 (WEB-FONT-DESCR :HEIGHT) of
 DESCR))
                       (MAX-ASCENT (fetch
 (WEB-FONT-DESCR :MAX-ASCENT) of
 DESCR))
                       (MAX-DESCENT (fetch
 (WEB-FONT-DESCR :MAX-DESCENT) of
 DESCR))
                       (SLUG-WIDTH (fetch
 (WEB-FONT-DESCR :SLUG-WIDTH) of
 DESCR))
                       (CHARSETS (fetch
 (WEB-FONT-DESCR :CHARSETS) of
 DESCR)))
                      (\HTML-DBG
 "font: ~A face: ~A size: ~A height: ~A #charsets: ~d~%%" FAMILY FACE
                             SIZE HEIGHT (LENGTH CHARSETS))
                      DESCR))))

(CL:DEFUN \HTML.READ-CHARSET-METRICS
 (FAMILY SIZE FACE CHARSET-NUM DIR)
   "Read a file containing a charset's metrics and return the WEB-CHARSET-METRICS"
   [LET* ((WEIGHT (fetch
 (WEB-FONT-FACE :WEIGHT) of
 FACE))
          (SLOPE (fetch
 (WEB-FONT-FACE :SLOPE) of
 FACE))
          (EXPANSION (fetch
 (WEB-FONT-FACE :EXPANSION) of
 FACE))
          (FILE-NAME (PACKFILENAME.STRING 'DIRECTORY DIR 'NAME (MAKE-CHARSET-METRICS-FILE-NAME
 FAMILY
                                                                      SIZE WEIGHT SLOPE EXPANSION 
                                                                      CHARSET-NUM)))
          (*PACKAGE* (CL:FIND-PACKAGE "IL")))
         (AND (INFILEP FILE-NAME)
              (CL:WITH-OPEN-STREAM (IN
 (OPENSTREAM FILE-NAME 'INPUT))
                     (CHECK-BROWSER-METRICS-FORMAT
 (READ IN))
                     (LET* ((CHARSET (READ IN))
                            (MAX-ASCENT (fetch
 (WEB-CHARSET-METRICS :MAX-ASCENT) of
 CHARSET))
                            (MAX-DESCENT (fetch
 (WEB-CHARSET-METRICS :MAX-DESCENT) of
 CHARSET))
                            (WIDTHS (fetch
 (WEB-CHARSET-METRICS :WIDTHS) of
 CHARSET)))
                           (\HTML-DBG
 "charset family: ~A face: ~A size: ~A charset: ~d~%%" FAMILY 
                                  FACE SIZE CHARSET-NUM)
                           CHARSET])

(CL:DEFUN \HTML.SVG-STROKE-DASHARRAY
 (DASHING)
   "Turn an array of dashes (on/off sequences) to an SVG stroke-dasharray attribute"
   [if
 (NULL DASHING)
       then
 ""
     else
 
          (* ;; 

          "If the DASHING list has an odd length, keep SVG from %"reflecting%" it by appending a 0")


          [if
 (ODDP (LENGTH DASHING))
              then
 (SETQ DASHING (APPEND DASHING (LIST 0]
          (CL:FORMAT NIL " stroke-dasharray='~A'"
                 (CONCATLIST (for
 SENSOR on
 DASHING as
 ON-OFF in
 DASHING
                                collect
 (if
 (NOT (NUMBERP ON-OFF))
                                            then
 (ERROR "Dashes must be numbers" ON-OFF))
                                      (if
 (CDR SENSOR)
                                          then
 (CONCAT ON-OFF " ")
                                        else
 ON-OFF])

(CL:DEFUN \HTML.SVG-BRUSH-WIDTH
 (BRUSH-SPEC)
   "Convert a brush specification to a width SVG can use"
   (COND
      ((AND (LISTP BRUSH-SPEC)
            (LITATOM (CAR BRUSH-SPEC))
            (NUMBERP (CADR BRUSH-SPEC)))
       (CADR BRUSH-SPEC))
      ((NUMBERP BRUSH-SPEC)
       BRUSH-SPEC)
      (T (ERROR "Not a valid brush:" BRUSH-SPEC))))

(CL:DEFUN \HTML.SVG-BRUSH-CLASS
 (BRUSH-SPEC)
   "Convert the brush to a CSS class value."
   (LET [(LINEJOIN-CLASS (COND
                            ((AND (LISTP BRUSH-SPEC)
                                  (LITATOM (CAR BRUSH-SPEC))
                                  (NUMBERP (CADR BRUSH-SPEC)))
                             (SELECTQ (CAR BRUSH-SPEC)
                                 (ROUND "joinr")
                                 (SQUARE "joinm")
                                 "joinm"))
                            (T "joinm")))
         (LINECAP-CLASS (COND
                           ((AND (LISTP BRUSH-SPEC)
                                 (LITATOM (CAR BRUSH-SPEC))
                                 (NUMBERP (CADR BRUSH-SPEC)))
                            (SELECTQ (CAR BRUSH-SPEC)
                                (ROUND "capr")
                                (SQUARE "caps")
                                "capb"))
                           (T "capb"]
        (CONCAT LINEJOIN-CLASS " " LINECAP-CLASS)))

(CL:DEFUN \HTML.SVG-COLOR
 (COLOR)
   "Given a Medley color, convert it to an RGB value for SVG, #rrggbb."
   (LET ((TRIPLE (INSURE.RGB.COLOR COLOR)))                  (* ; "returns an RGB list")

        (CL:FORMAT NIL "#~2,'0x~2,'0x~2,'0x" (CAR TRIPLE)
               (CADR TRIPLE)
               (CADDR TRIPLE))))

(CL:DEFSTRUCT (HTML.IMAGEDATA
 (:CONC-NAME \HTML-))
   "Private data for HTMLSTREAMs"
   BACKING-STREAM
   FONT
   CLIPPING-REGION
   (SPACE-FACTOR 1.0)
   IMAGE-OPERATION
   (FG-COLOR (INSURE.RGB.COLOR 'BLACK))
   (BG-COLOR (INSURE.RGB.COLOR 'WHITE))
   (SVG-FG-COLOR (\HTML.SVG-COLOR
 'BLACK))                   (* ; "stored as %"#rrggbb%"")

   (SVG-BG-COLOR (\HTML.SVG-COLOR
 'WHITE))                   (* ; "stored as %"#rrggbb%"")

   (SCALE *CENTIPOINTS-PER-POINT*)
   (PAGE-NUM 0)
   (X-POSITION 0)
   (Y-POSITION 0)
   (LEFT-MARGIN 0)
   (TOP-MARGIN 1024)
   (RIGHT-MARGIN 1024)
   (BOTTOM-MARGIN 0)
   (LINEFEED 12)
   (STATE HTML.STATE.BETWEEN-PAGES)
   PAGE-HEIGHT PAGE-WIDTH TITLE)

(CL:DEFSTRUCT (HTML.FONTINFO
 (:CONC-NAME \HTMLFONT-)
                             [:PRINT-FUNCTION (LAMBDA (OBJ STREAM DEPTH)
                                                (CL:FORMAT STREAM "<~a css: '~a' slug: ~a>"
                                                       (\HTML.TOADDR
 OBJ)
                                                       (\HTMLFONT-CSS-CLASS OBJ)
                                                       (\HTMLFONT-SLUG-WIDTH OBJ])
   "Private data for an HTML FONTDESCRIPTOR"
   (CHARSETS NIL)
   (CSS-CLASS NIL)
   (SLUG-WIDTH NIL)
   (WARNED-CHARSETS NIL))

(DEFMACRO with-htmldata
 ((DATA-VAR-NAME STREAM)
                         &BODY
                         (BODY DECLS ENV))
   `(LET [(,DATA-VAR-NAME (fetch
 (STREAM IMAGEDATA) of
 ,STREAM]
         ,@DECLS
         ,@BODY))

(CL:DEFUN HTML.OUTPUT-GRAPHICS
 (STREAM)
   "We're going to do some graphics now"
   (with-htmldata
 (DATA STREAM)
          (\HTML.MAYBE-START-PAGE
 DATA STREAM)
          (SELECTC (\HTML-STATE DATA)
              (HTML.STATE.NON-TEXT-OUTPUT                    (* ; "this is the state we need")

                   )
              (HTML.STATE.TEXT-OUTPUT                        (* ; "end the text section")

                   (CL:FORMAT (\HTML-BACKING-STREAM DATA)
                          "</text>~%%"))
              NIL)

          (* ;; "finally")


          (CL:SETF (\HTML-STATE DATA)
                 HTML.STATE.NON-TEXT-OUTPUT)))

(CL:DEFUN HTML.OUTPUT-TEXT
 (STREAM)
   "We're being asked to write text"
   (with-htmldata
 (DATA STREAM)
          (\HTML.MAYBE-START-PAGE
 DATA STREAM)
          (LET* ((FONT (\HTML-FONT DATA))
                 (FONT-DATA (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 FONT)))
                (SELECTC (\HTML-STATE DATA)
                    ((LIST HTML.STATE.NON-TEXT-OUTPUT HTML.STATE.BETWEEN-PAGES) 
                                                             (* ; "start a new text section")

                         (CL:FORMAT (\HTML-BACKING-STREAM DATA)
                                "<text class='~a' fill='~a' x='~d' y='~d'>"
                                (\HTMLFONT-CSS-CLASS FONT-DATA)
                                (\HTML-SVG-FG-COLOR DATA)
                                (\HTML-X-POSITION DATA)
                                (\HTML.SVG-Y
 DATA (\HTML-Y-POSITION DATA))))
                    (HTML.STATE.TEXT-OUTPUT                  (* ; "continue this text section")

                         )
                    NIL)

                (* ;; "finally")


                (CL:SETF (\HTML-STATE DATA)
                       HTML.STATE.TEXT-OUTPUT))))

(CL:DEFUN \HTML.MAYBE-START-PAGE
 (DATA STREAM)

   (* ;; "We're going to do output of some sort, so start an SVG stanza if necessary")


   [with-htmldata
 (DATA STREAM)
          (if
 (EQ (\HTML-STATE DATA)
                  HTML.STATE.BETWEEN-PAGES)
              then
 (LET ((BACKING (\HTML-BACKING-STREAM DATA)))
                        (CL:FORMAT BACKING 
            "<svg width='~dpt' height='~dpt' viewBox='~d ~d ~d ~d' style='background-color: ~a;'>~%%"
                               (CP-TO-P
 (\HTML-PAGE-WIDTH DATA))
                               (CP-TO-P
 (\HTML-PAGE-HEIGHT DATA))
                               0 0 (\HTML-PAGE-WIDTH DATA)
                               (\HTML-PAGE-HEIGHT DATA)
                               (\HTML-SVG-BG-COLOR DATA))
                        [CL:SETF (\HTML-TOP-MARGIN DATA)
                               (- (\HTML-PAGE-HEIGHT DATA)
                                  (FONTPROP (\HTML-FONT DATA)
                                         'HEIGHT]

                        (* ;; "Don't reset X, just Y")


                        (CL:SETF (\HTML-Y-POSITION DATA)
                               (\HTML-TOP-MARGIN DATA])

(CL:DEFUN \HTML.END-PAGE
 (DATA STREAM)
   "End the current page"
   (if
 (EQ (\HTML-STATE DATA)
           HTML.STATE.TEXT-OUTPUT)
       then
 (HTML.OUTPUT-GRAPHICS
 STREAM))
   (CL:INCF (\HTML-PAGE-NUM DATA))
   (HTML.RESET
 STREAM)
   (LET ((BACKING (\HTML-BACKING-STREAM DATA)))
        (CL:FORMAT BACKING "</svg>~%%"))
   (CL:SETF (\HTML-STATE DATA)
          HTML.STATE.BETWEEN-PAGES))

(CL:DEFUN \HTML.TAB-DELTA-X
 (HTML-DATA)
   "Return the distance a TAB will move in the X dimension"
   (LET [(TABSPACE (TIMES TAB-WIDTH-IN-CHARACTERS (ffetch
 FONTAVGCHARWIDTH of
 (\HTML-FONT HTML-DATA]
        (IDIFFERENCE TABSPACE (IREMAINDER (IDIFFERENCE (\HTML-X-POSITION HTML-DATA)
                                                 (\HTML-LEFT-MARGIN HTML-DATA))
                                     TABSPACE))))

(CL:DEFUN \HTML.CHARWIDTH
 (STREAM CHCODE)
   "Raw character width accessor that coerces undefined characters to slug"
   [with-htmldata
 (DATA STREAM)
          (LET* [(FONT-INFO (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 (\HTML-FONT DATA)))
                 (CHARSET-INFO (\INSURECHARSETINFO (\HTML-FONT DATA)
                                      (\CHARSET CHCODE]
                (DO-NOT
 (PRINTOUT T "Widths: " (FETCH
 (CHARSETINFO WIDTHS) OF
 CHARSET-INFO)
                               T)
                       (PRINTOUT T "Did get widths" T))
                (if
 (= CHCODE *XCCS-UNDEFINED-CHARCODE*)
                    then
 (\HTMLFONT-SLUG-WIDTH FONT-INFO)
                  else
 (\FGETCHARWIDTH (\HTML-FONT DATA)
                              CHCODE])

(CL:DEFUN HTML.WRITE-PREFACE
 (STREAM)
   "Write the preamble to the file: <html><head>... etc."
   (with-htmldata

    (DATA STREAM)
    (LET ((BACKING (\HTML-BACKING-STREAM DATA))
          (TITLE (\HTML-TITLE DATA))
          (FAMILY-VAR-NAMES NIL))
         (CL:FLET ((FONT-DEF (VAR-NAME FAMILY)
                          (CL:FORMAT BACKING "    const ~a = [" VAR-NAME)
                          (PUSH
 FAMILY-VAR-NAMES VAR-NAME)
                          [LET ((FAMILY-MEMBERS (LISTGET *HTML-STYLESHEET-FONT-FAMILY-DEFS* FAMILY)))
                               (for
 FONT in
 FAMILY-MEMBERS as
 TAIL on
 FAMILY-MEMBERS
                                  do
 (if
 (CDR TAIL)
                                         then
 (CL:FORMAT BACKING "%"~a%"," FONT)
                                       else
 (CL:FORMAT BACKING "%"~a%"" FONT]
                          (CL:FORMAT BACKING "].map(singleQuote).join(%",%");~%%")))
                (CL:FORMAT BACKING "<!DOCTYPE HTML>~%%")
                (CL:FORMAT BACKING "<html>~%%")
                (CL:FORMAT BACKING "<head>~%%")
                (CL:FORMAT BACKING "<meta charset='utf-8'>~%%")
                (CL:FORMAT BACKING "<title>~a</title>~%%" (HTML-ENCODE
 TITLE))
                (CL:FORMAT BACKING 
                       "<!-- Created by Medley Interlisp software. Details at interlisp.org. -->~%%")
                (CL:FORMAT BACKING 
                       "<link rel=%"preconnect%" href=%"https://fonts.googleapis.com%">~%%")
                (CL:FORMAT BACKING 
                       "<link rel=%"preconnect%" href=%"https://fonts.gstatic.com%" crossorigin>~%%")
                [for
 FAMILY in
 *HTML-STANDARD-PAGE-WEB-FONT-FAMILIES*
                   do
 (CL:FORMAT BACKING "<link rel=%"stylesheet%" href=%"~a%">~%%"
                             (\HTML.MAKE-STYLESHEET-URL
 (LISTGET *HTML-STYLESHEET-FONT-FAMILY-DEFS* 
                                                               FAMILY]
                (CL:FORMAT BACKING "<script>~%%")
                (CL:FORMAT BACKING "    function singleQuote(fn) { return %"'%" + fn + %"'%"; }~%%")
                (FONT-DEF "notoSans" 'NOTO-SANS)
                (FONT-DEF "notoSansMono" 'NOTO-SANS-MONO)
                (FONT-DEF "notoSansDisplay" 'NOTO-SANS-DISPLAY)
                (FONT-DEF "notoSerif" 'NOTO-SERIF)
                (FONT-DEF "notoSerifDisplay" 'NOTO-SERIF-DISPLAY)
                (CL:FORMAT BACKING "    const sizes = [")
                (for
 SIZE in
 *WEB-FONT-SIZES* do
 (CL:FORMAT BACKING "~d, " SIZE))
                (CL:FORMAT BACKING "];~%%")
                (CL:FORMAT BACKING "    const families = [")
                (for
 FAMILY-VAR in
 FAMILY-VAR-NAMES do
 (CL:FORMAT BACKING "~a, " FAMILY-VAR))
                (CL:FORMAT BACKING "];~%%")
                (CL:FORMAT BACKING "    const fontLoadPromises = [];~%%")
                (CL:FORMAT BACKING "    for (const family of families) {~%%")
                (CL:FORMAT BACKING "        for (const size of sizes) {~%%")
                (CL:FORMAT BACKING 
                    "            fontLoadPromises.push(document.fonts.load(size+%"pt %"+family));~%%"
                       )
                (CL:FORMAT BACKING "        }~%%")
                (CL:FORMAT BACKING "    }~%%")
                (CL:FORMAT BACKING 
               "    Promise.all(fontLoadPromises).then(_ => { console.log('All fonts loaded');});~%%"
                       )
                (CL:FORMAT BACKING "</script>~%%")

                (* ;; "define styles")


                (CL:FORMAT BACKING "<style>~%%")

                (* ;; "all space chars in text blocks are significant:")


                (CL:FORMAT BACKING "text { white-space: pre; }~%%")

                (* ;; 

 "the page is scaled to use centipoints, so font sizes below are measured in centipoints, not points")


                (* ;; "define font families as CSS classes")


                (for
 FONT-FAMILY in
 *HTML-STANDARD-PAGE-WEB-FONT-FAMILIES*
                   do
 (CL:FORMAT BACKING ".~A { font-family: " (CDR (FASSOC FONT-FAMILY 
                                                                           *WEB-FONT-FAMILIES*)))
                      [LET ((FONTS (LISTGET *HTML-STYLESHEET-FONT-FAMILY-DEFS* FONT-FAMILY)))
                           (for
 FONT in
 FONTS as
 TAIL on
 FONTS
                              do
 (if
 (CDR TAIL)
                                     then
 (CL:FORMAT BACKING "'~a', " FONT)
                                   else
 (CL:FORMAT BACKING "'~a', ~a" FONT (CDR (FASSOC FONT-FAMILY 
                                                                                  *BROWSER-FONTS-MAP*
                                                                                       ]
                      (CL:FORMAT BACKING "; }~%%"))

                (* ;; "define font sizes as CSS classes")


                [for
 SIZE in
 *WEB-FONT-SIZES* do
 (CL:FORMAT BACKING ".sz~d { font-size: ~dpt; }~%%" 
                                                        SIZE (FIXR (P-TO-CP
 SIZE]

                (* ;; "define faces as CSS classes")


                (CL:FORMAT BACKING ".bold { font-weight: bold; }~%%")
                (CL:FORMAT BACKING ".italic { font-style: italic; }~%%")

                (* ;; "define stroke-linejoin and stroke-linecap CSS classes")


                (* ;; "linecaps")


                (CL:FORMAT BACKING ".capb { stroke-linecap: butt; }~%%")
                (CL:FORMAT BACKING ".capr { stroke-linecap: round; }~%%")
                (CL:FORMAT BACKING ".caps { stroke-linecap: square; }~%%")

                (* ;; "linejoins")


                (CL:FORMAT BACKING ".joinm { stroke-linejoin: miter; }~%%")
                (CL:FORMAT BACKING ".joinr { stroke-linejoin: round; }~%%")
                (CL:FORMAT BACKING ".joinb { stroke-linejoin: bevel; }~%%")

                (* ;; "end of the style definitions")


                (CL:FORMAT BACKING "</style>~%%")
                (CL:FORMAT BACKING "</head>~%%")
                (CL:FORMAT BACKING "<body>~%%"))
         BACKING)))

(CL:DEFUN CONVERT-FAMILY-TO-QUERY-PARAM
 (FONT-FAMILY-NAME &OPTIONAL (INITIAL-PARAM? NIL))
   "Convert a font family name like 'Noto Sans' to a URL query param like '&family=Noto+Sans'"
   (CL:FLET ((REPLACE-SPACES (STR)
                    (LET* ((STR-LENGTH (CL:LENGTH STR))
                           (NEW-STR (CL:MAKE-STRING STR-LENGTH)))
                          [for
 I from
 0 to
 (CL:1- STR-LENGTH)
                             do
 (LET ((CH (CL:CHAR STR I)))
                                     (CL:SETF (CL:CHAR NEW-STR I)
                                            (if
 (EQP CH #\Space)
                                                then
 #\+
                                              else
 (CL:CHAR STR I]
                          NEW-STR)))
          (CONCAT (if
 INITIAL-PARAM?
                      then
 "?"
                    else
 "&")
                 "family="
                 (REPLACE-SPACES FONT-FAMILY-NAME))))

(CL:DEFUN \HTML.MAKE-STYLESHEET-URL
 (FONT-FAMILY-NAMES)
   "Return the stylesheet URL for downloading the given font family names from Google Fonts"
   [LET [(FULL-URL (CONCAT *GOOGLE-FONTS-BASE-URL* (CONVERT-FAMILY-TO-QUERY-PARAM
 (CAR 
                                                                                    FONT-FAMILY-NAMES
                                                                                       )
                                                          T]
        (CONCAT FULL-URL (APPLY* #'CONCATLIST (MAPCAR (CDR FONT-FAMILY-NAMES)
                                                     #'CONVERT-FAMILY-TO-QUERY-PARAM])

(CL:DEFUN OPENHTMLSTREAM
 (FILENAME &OPTIONAL OPTIONS)
   "Open and return an HTML imagestream"
   (LET* ((TITLE (OR (LISTGET OPTIONS 'TITLE)
                     FILENAME))
          (REGION (OR (LISTGET OPTIONS 'REGION)
                      *HTML.DEFAULT-PAGE-REGION*))
          [BACKING (OPENSTREAM FILENAME 'OUTPUT NIL '((FORMAT :UTF-8-SLUG]
          (IMAGEOPS (create
 IMAGEOPS))
          (IMAGEDATA (MAKE-HTML.IMAGEDATA :BACKING-STREAM BACKING :TITLE (CL:FORMAT NIL "~a" TITLE)
                            :PAGE-WIDTH
                            (fetch
 (REGION WIDTH) of
 REGION)
                            :PAGE-HEIGHT
                            (fetch
 (REGION HEIGHT) of
 REGION)))
          (HTMLSTREAM (create
 STREAM
                             FULLFILENAME _ (FULLNAME BACKING)
                             DEVICE _ \HTMLSTREAM.FDEV
                             ACCESS _ 'OUTPUT
                             OUTCHARFN _ #'HTML.OUTCHARFN
                             STRMBOUTFN _ #'\BUFFERED.BOUT   (* ; "is this right?")

                             IMAGEOPS _ IMAGEOPS
                             USERCLOSEABLE _ T
                             USERVISIBLE _ T
                             IMAGEDATA _ IMAGEDATA)))

         (* ;; "Make the backing file invisible")


         (replace
 (STREAM USERVISIBLE) of
 BACKING with
 NIL)

         (* ;; "install our OUTCHARFN. you can't do this in the create.")


         (replace
 (STREAM OUTCHARFN) of
 HTMLSTREAM with
 #'HTML.OUTCHARFN)

         (* ;; "Set the informational fields")


         (replace
 IMFONTCREATE of
 IMAGEOPS with
 HTML.FONTCREATE.DEVICENAME)
         (replace
 IMAGETYPE of
 IMAGEOPS with
 HTML.IMAGETYPE)

         (* ;; "Set the functions")


         (replace
 IMCLOSEFN of
 IMAGEOPS with
 #'HTML.CLOSEFN)
         (replace
 IMDRAWLINE of
 IMAGEOPS with
 #'HTML.DRAWLINE)
         (replace
 IMDRAWCURVE of
 IMAGEOPS with
 #'HTML.DRAWCURVE)
         (replace
 IMDRAWCIRCLE of
 IMAGEOPS with
 #'HTML.DRAWCIRCLE)
         (replace
 IMDRAWELLIPSE of
 IMAGEOPS with
 #'HTML.DRAWELLIPSE)
         (replace
 IMDRAWARC of
 IMAGEOPS with
 #'HTML.DRAWARC)
         (replace
 IMFILLPOLYGON of
 IMAGEOPS with
 #'HTML.FILLPOLYGON)
         (replace
 IMDRAWPOLYGON of
 IMAGEOPS with
 #'HTML.DRAWPOLYGON)
         (replace
 IMFILLCIRCLE of
 IMAGEOPS with
 #'HTML.FILLCIRCLE)
         (replace
 IMBLTSHADE of
 IMAGEOPS with
 #'HTML.BLTSHADE)
         (replace
 IMBITBLT of
 IMAGEOPS with
 #'HTML.BITBLT)
         (replace
 IMSCALEDBITBLT of
 IMAGEOPS with
 #'HTML.SCALEDBITBLT)
         (replace
 IMMOVETO of
 IMAGEOPS with
 #'HTML.MOVETO)
         (replace
 IMCHARWIDTH of
 IMAGEOPS with
 #'HTML.CHARWIDTH)
         (replace
 IMNEWPAGE of
 IMAGEOPS with
 #'HTML.NEWPAGE)
         (replace
 IMTERPRI of
 IMAGEOPS with
 #'HTML.TERPRI)
         (replace
 IMRESET of
 IMAGEOPS with
 #'HTML.RESET)
         (replace
 IMCLIPPINGREGION of
 IMAGEOPS with
 #'HTML.CLIPPINGREGION)
         (replace
 IMXPOSITION of
 IMAGEOPS with
 #'HTML.XPOSITION)
         (replace
 IMYPOSITION of
 IMAGEOPS with
 #'HTML.YPOSITION)
         (replace
 IMFONT of
 IMAGEOPS with
 #'HTML.FONT)
         (replace
 IMLEFTMARGIN of
 IMAGEOPS with
 #'HTML.LEFTMARGIN)
         (replace
 IMRIGHTMARGIN of
 IMAGEOPS with
 #'HTML.RIGHTMARGIN)
         (replace
 IMTOPMARGIN of
 IMAGEOPS with
 #'HTML.TOPMARGIN)
         (replace
 IMBOTTOMMARGIN of
 IMAGEOPS with
 #'HTML.BOTTOMMARGIN)
         (replace
 IMLINEFEED of
 IMAGEOPS with
 #'HTML.LINEFEED)
         (replace
 IMSCALE of
 IMAGEOPS with
 #'HTML.SCALE)
         (replace
 IMSPACEFACTOR of
 IMAGEOPS with
 #'HTML.SPACEFACTOR)
         (replace
 IMOPERATION of
 IMAGEOPS with
 #'HTML.OPERATION)
         (replace
 IMBACKCOLOR of
 IMAGEOPS with
 #'HTML.BACKCOLOR)
         (replace
 IMCOLOR of
 IMAGEOPS with
 #'HTML.COLOR)

         (* ;; "Maybe implement these later:")


         (replace
 IMWRITEPIXEL of
 IMAGEOPS with
 #'NILL)
         (replace
 IMROTATE of
 IMAGEOPS with
 #'NILL)
         (replace
 IMTRANSLATE of
 IMAGEOPS with
 #'NILL)
         (replace
 IMSCALE2 of
 IMAGEOPS with
 #'NILL)
         (replace
 IMPUSHSTATE of
 IMAGEOPS with
 #'NILL)
         (replace
 IMPOPSTATE of
 IMAGEOPS with
 #'NILL)
         (replace
 IMDEFAULTSTATE of
 IMAGEOPS with
 #'NILL)
         (replace
 IMCHARWIDTHY of
 IMAGEOPS with
 #'NILL)

         (* ;; "we can init the font now that the IMAGEOPS are complete")


         (LET* [(USER-FONT (LISTGET OPTIONS 'FONT))
                (DEFAULT-FONT (if
 USER-FONT
                                  then
 (FONTCREATE USER-FONT HTMLSTREAM) 
                                                             (* ; "right??!")

                                else
 (FONTCREATE 'NOTO-SANS 10 'MRR 0 'HTML]

               (* ;; "Finish initializing the IMAGEDATA")


               (\HTML.INIT-IMAGEDATA
 HTMLSTREAM DEFAULT-FONT)

               (* ;; "write the preface")


               (HTML.WRITE-PREFACE
 HTMLSTREAM)

               (* ;; "return the stream")


               HTMLSTREAM)))

(CL:DEFUN HTML.BACKCOLOR
 (STREAM NEW-COLOR)
   "Set the bg color. Generate the SVG color and set it into the imagedata. Affects next page geenerated."
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-BG-COLOR DATA)))
               [COND
                  (NEW-COLOR (LET ((EFFECTIVE-COLOR (INSURE-COLOR-OR-SHADE
 NEW-COLOR)))
                                  (CL:WHEN (NEQ EFFECTIVE-COLOR OLD-VALUE)
                                      (CL:SETF (\HTML-BG-COLOR DATA)
                                             EFFECTIVE-COLOR)
                                      (CL:SETF (\HTML-SVG-BG-COLOR DATA)
                                             (\HTML.SVG-COLOR
 EFFECTIVE-COLOR))
                                      (HTML.OUTPUT-GRAPHICS
 STREAM))]
               OLD-VALUE)))

(CL:DEFUN HTML.BITBLT
 (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM
                             WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION 
                             CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM)

   (* ;; "blt the image expanded by a scale factor of 1")


   (HTML.SCALEDBITBLT
 SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM 
          WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
          CLIPPEDSOURCEBOTTOM 1))

(CL:DEFUN HTML.BLTSHADE
 (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION 
                               CLIPPINGREGION)

   (* ;; "NOTE we ignore OPERATION")


   (* ;; "in our monochrome graphics world, SHADEs are 4x4 TEXTUREs.  Let's interpret the texture as a shade, meaning a gray value")


   (* ;; "because we're dealing with 24-bit color, we can only represent 256 gray shades")


   [LET* [(BLACK-BITS (CL:LOGCOUNT TEXTURE))
          (BLACK-PROPORTION (/ BLACK-BITS 16))
          (GRAY-VALUE (FIXR (TIMES BLACK-PROPORTION 255]
         (with-htmldata
 (DATA STREAM)

                (* ;; "clip region against CLIPPINGREGION")


                (LET* [(BACKING (\HTML-BACKING-STREAM DATA))
                       (ORIGINAL-REGION (CREATE
 REGION
                                               LEFT _ DESTINATIONLEFT
                                               BOTTOM _ DESTINATIONBOTTOM
                                               WIDTH _ WIDTH
                                               HEIGHT _ HEIGHT))
                       (EFFECTIVE-REGION (INTERSECTREGIONS ORIGINAL-REGION (CL:IF CLIPPINGREGION
                                                                               CLIPPINGREGION
                                                                               ORIGINAL-REGION)]
                      (HTML.OUTPUT-GRAPHICS
 STREAM)
                      (CL:FORMAT BACKING 
           "<rect x='~d' y='~d' width='~d' height='~d' stroke='none' fill='#~2,'0x~2,'0x~2,'0x'/>~%%"
                             (FETCH
 (REGION LEFT) OF
 EFFECTIVE-REGION)
                             (\HTML.SVG-Y
 DATA (FETCH
 (REGION BOTTOM) OF
 EFFECTIVE-REGION))
                             (FETCH
 (REGION WIDTH) OF
 EFFECTIVE-REGION)
                             (FETCH
 (REGION HEIGHT) OF
 EFFECTIVE-REGION)
                             GRAY-VALUE GRAY-VALUE GRAY-VALUE])

(CL:DEFUN HTML.BOTTOMMARGIN
 (STREAM NEW-BOTTOM-MARGIN)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-BOTTOM-MARGIN DATA)))
               (COND
                  (NEW-BOTTOM-MARGIN (CL:SETF (\HTML-BOTTOM-MARGIN DATA)
                                            NEW-BOTTOM-MARGIN)))
               OLD-VALUE)))

(CL:DEFUN HTML.CHARWIDTH
 (STREAM CHCODE)
   "Character width accessor that obeys space-factors"
   (with-htmldata
 (DATA STREAM)
          (LET* ((FONT-INFO (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 (\HTML-FONT DATA)))
                 (CHAR-WIDTH (if
 (= CHCODE *XCCS-UNDEFINED-CHARCODE*)
                                 then
 (\HTMLFONT-SLUG-WIDTH FONT-INFO)
                               else
 (\FGETCHARWIDTH (\HTML-FONT DATA)
                                           CHCODE)))
                 (SPACE-FACTOR (\HTML-SPACE-FACTOR DATA)))
                (if
 (AND (= CHCODE (CHARCODE SPACE))
                         (NOT (= SPACE-FACTOR 1)))
                    then
 (FTIMES SPACE-FACTOR CHAR-WIDTH)
                  else
 CHAR-WIDTH))))

(CL:DEFUN HTML.CLIPPINGREGION
 (STREAM NEW-REGION)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-CLIPPING-REGION DATA)))
               (COND
                  (NEW-REGION (CL:SETF (\HTML-CLIPPING-REGION DATA)
                                     NEW-REGION)))
               OLD-VALUE)))

(CL:DEFUN HTML.CLOSEFN
 (STREAM)
   (with-htmldata
 (DATA STREAM)
          (LET ((BACKING (\HTML-BACKING-STREAM DATA)))
               (if
 (EQ (\HTML-STATE DATA)
                       HTML.STATE.TEXT-OUTPUT)
                   then
 (HTML.OUTPUT-GRAPHICS
 STREAM))
               (if
 (EQ (\HTML-STATE DATA)
                       HTML.STATE.BETWEEN-PAGES)
                   then
 (printout BACKING T "</body>" T "</html>" T)
                 else
 (printout BACKING T "</svg>" T "</body>" T "</html>" T))
               (CLOSEF BACKING)
               (CL:SETF (\HTML-STATE DATA)
                      HTML.STATE.CLOSED))))

(CL:DEFUN HTML.COLOR
 (STREAM NEW-COLOR)
   "Return and optionally set the color of the stream"
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-FG-COLOR DATA)))
               [COND
                  (NEW-COLOR (LET ((EFFECTIVE-COLOR (INSURE-COLOR-OR-SHADE
 NEW-COLOR)))
                                  (CL:WHEN (NEQ EFFECTIVE-COLOR OLD-VALUE)
                                      (CL:SETF (\HTML-FG-COLOR DATA)
                                             EFFECTIVE-COLOR)
                                      (CL:SETF (\HTML-SVG-FG-COLOR DATA)
                                             (\HTML.SVG-COLOR
 EFFECTIVE-COLOR))
                                      (HTML.OUTPUT-GRAPHICS
 STREAM))]
               OLD-VALUE)))

(CL:DEFUN HTML.DRAWCIRCLE
 (STREAM CENTERX CENTERY RADIUS BRUSH DASHING)
   "Draw a circle"
   (with-htmldata
 (DATA STREAM)
          (HTML.OUTPUT-GRAPHICS
 STREAM)
          (LET ((BACKING (\HTML-BACKING-STREAM DATA)))
               (CL:FORMAT BACKING 
  "<circle class='~a' cx='~d' cy='~d' r='~d' fill='transparent' stroke='~a' stroke-width='~d'~A/>~%%"
                      (\HTML.SVG-BRUSH-CLASS
 BRUSH)
                      CENTERX
                      (\HTML.SVG-Y
 DATA CENTERY)
                      RADIUS
                      (\HTML-SVG-FG-COLOR DATA)
                      (\HTML.SVG-BRUSH-WIDTH
 BRUSH)
                      (\HTML.SVG-STROKE-DASHARRAY
 DASHING)))
          (HTML.MOVETO
 STREAM CENTERX CENTERY)))

(CL:DEFUN HTML.DRAWCURVE
 (STREAM KNOTS CLOSED BRUSH DASHING)
   "Interpret the knots as points on a cubic parametric curve, convert to cubic Bezier form, and draw it"
   (with-htmldata
 (DATA STREAM)
          (HTML.OUTPUT-GRAPHICS
 STREAM)

          (* ;; "TODO deal with BRUSH, color, and DASHING")


          (LET* ((BACKING (\HTML-BACKING-STREAM DATA))
                 (STROKE-WIDTH (\HTML.SVG-BRUSH-WIDTH
 BRUSH))
                 (SPLINE (PARAMETRICSPLINE KNOTS CLOSED NIL))
                 (N (fetch
 (SPLINE %#KNOTS) of
 SPLINE))
                 (XA (fetch
 (SPLINE SPLINEX) of
 SPLINE))
                 (YA (fetch
 (SPLINE SPLINEY) of
 SPLINE))
                 (DXA (fetch
 (SPLINE SPLINEDX) of
 SPLINE))
                 (DYA (fetch
 (SPLINE SPLINEDY) of
 SPLINE))
                 (PREVX (ELT XA 1))
                 (PREVY (ELT YA 1))
                 (PREV-DX3 (FQUOTIENT (ELT DXA 1)
                                  3.0))
                 (PREV-DY3 (FQUOTIENT (ELT DYA 1)
                                  3.0))
                 (PATH (CONCAT "M " PREVX " " (\HTML.SVG-Y
 DATA PREVY)
                              " "))                          (* ; "start at PREVX, PREVY")

                 )
                (for
 C from
 2 to
 N do
 (SETQ PATH (CONCAT PATH "C " (FPLUS PREVX PREV-DX3)
                                                        " "
                                                        (\HTML.SVG-Y
 DATA (FPLUS PREVY PREV-DY3))
                                                        " "
                                                        (FDIFFERENCE (SETQ PREVX (ELT XA C))
                                                               (SETQ PREV-DX3 (FQUOTIENT (ELT DXA C)
                                                                                     3.0)))
                                                        " "
                                                        [\HTML.SVG-Y
 DATA
                                                               (FDIFFERENCE (SETQ PREVY
                                                                             (ELT YA C))
                                                                      (SETQ PREV-DY3
                                                                       (FQUOTIENT (ELT DYA C)
                                                                              3.0]
                                                        " " PREVX " " (\HTML.SVG-Y
 DATA PREVY)
                                                        " ")))
                (CL:FORMAT BACKING 
                       "<path class='~a' fill='none' stroke='~a' stroke-width='~d'~A d='~A' />~%%"
                       (\HTML.SVG-BRUSH-CLASS
 BRUSH)
                       (\HTML-SVG-FG-COLOR DATA)
                       STROKE-WIDTH
                       (\HTML.SVG-STROKE-DASHARRAY
 DASHING)
                       PATH)
                (HTML.MOVETO
 STREAM PREVX PREVY)
                NIL)))

(CL:DEFUN HTML.DRAWELLIPSE
 (STREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH
                                  DASHING)
   "Draw an ellipse"
   [with-htmldata
 (DATA STREAM)
          (HTML.OUTPUT-GRAPHICS
 STREAM)
          (LET ((BACKING (\HTML-BACKING-STREAM DATA)))
               (CL:FORMAT BACKING "<ellipse class='~a' stroke='~a' cx='~d' cy='~d' rx='~d' ry='~d' transform='rotate(~d,~d,~d)' fill='transparent'~A stroke-width='~d'/>~%%"
                      (\HTML.SVG-BRUSH-CLASS
 BRUSH)
                      (\HTML-SVG-FG-COLOR DATA)
                      CENTERX
                      (\HTML.SVG-Y
 DATA CENTERY)
                      SEMIMAJORRADIUS SEMIMINORRADIUS (- ORIENTATION)
                      CENTERX
                      (\HTML.SVG-Y
 DATA CENTERY)
                      (\HTML.SVG-STROKE-DASHARRAY
 DASHING)
                      (\HTML.SVG-BRUSH-WIDTH
 BRUSH])

(CL:DEFUN HTML.DRAWLINE
 (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING)
   "Draw a line"

   (* ;; "TODO implement OPERATION")


   (with-htmldata
 (DATA STREAM)
          (HTML.OUTPUT-GRAPHICS
 STREAM)
          (LET [(BACKING (\HTML-BACKING-STREAM DATA))
                (EFFECTIVE-COLOR (if
 COLOR
                                     then
 (\HTML.SVG-COLOR
 COLOR)
                                   else
 (\HTML-SVG-FG-COLOR DATA]
               (CL:FORMAT BACKING 
              "<line class='~a' stroke='~a' x1='~d' y1='~d' x2='~d' y2='~d' stroke-width='~d'~A/>~%%"
                      (\HTML.SVG-BRUSH-CLASS
 NIL)
                      EFFECTIVE-COLOR X1 (\HTML.SVG-Y
 DATA Y1)
                      X2
                      (\HTML.SVG-Y
 DATA Y2)
                      (OR WIDTH (P-TO-CP
 1))
                      (\HTML.SVG-STROKE-DASHARRAY
 DASHING)))
          (HTML.MOVETO
 STREAM X2 Y2)))

(CL:DEFUN HTML.DRAWPOLYGON
 (STREAM POINTS CLOSED BRUSH DASHING)
   "Draw an open or closed polygon"
   (HTML.OUTPUT-GRAPHICS
 STREAM)
   (with-htmldata
 (DATA STREAM)
          (LET ((WIDTH (\HTML.SVG-BRUSH-WIDTH
 BRUSH))
                (BACKING (\HTML-BACKING-STREAM DATA))
                (DRAWING-TYPE (if
 CLOSED
                                  then
 "polygon"
                                else
 "polyline")))
               (CL:FORMAT BACKING 
                      "<~a class='~a' fill='none' stroke='~a' stroke-width='~d'~A points='" 
                      DRAWING-TYPE (\HTML.SVG-BRUSH-CLASS
 BRUSH)
                      (\HTML-SVG-FG-COLOR DATA)
                      WIDTH
                      (\HTML.SVG-STROKE-DASHARRAY
 DASHING))
               [for
 POINT in
 POINTS do
 (CL:FORMAT BACKING "~d,~d " (CAR POINT)
                                              (\HTML.SVG-Y
 DATA (CDR POINT]
               (CL:FORMAT BACKING "' />~%%"))))

(CL:DEFUN HTML.DRAWARC
 (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING)
   "Draws an arc of the circle whose center point is (CENTERX CENTERY) and whose radius is RADIUS from the position at STARTANGLE degrees for NDEGREES number of degrees. If STARTANGLE is 0, the starting point will be (CENTERX (CENTERY + RADIUS)). If NDEGREES is positive, the arc will be counterclockwise. If NDEGREES is negative, the arc will be clockwise. The other arguments are interpreted as described in DRAWCIRCLE"
   (with-htmldata
 (DATA STREAM)
          (HTML.OUTPUT-GRAPHICS
 STREAM)
          (LET [(BACKING (\HTML-BACKING-STREAM DATA))
                [DRAW-FROM-X (PLUS CENTERX (TIMES RADIUS (COS STARTANGLE]
                [DRAW-FROM-Y (PLUS CENTERY (TIMES RADIUS (SIN STARTANGLE]
                [DRAW-TO-X (PLUS CENTERX (TIMES RADIUS (COS (PLUS STARTANGLE NDEGREES]
                (DRAW-TO-Y (PLUS CENTERY (TIMES RADIUS (SIN (PLUS STARTANGLE NDEGREES]
               (CL:FORMAT BACKING "<path class='~a' fill='transparent' d='M ~d,~d A ~d,~d 0 ~d ~d ~d,~d' stroke='~a' stroke-width='~d' ~A/>~%%"
                      (\HTML.SVG-BRUSH-CLASS
 BRUSH)
                      DRAW-FROM-X
                      (\HTML.SVG-Y
 DATA DRAW-FROM-Y)
                      RADIUS RADIUS (COND
                                       ((GREATERP NDEGREES 180)
                                        1)                   (* ; 

                                                 "large-arc-flag: 1=greater than half circle, 0=less")

                                       (T 0))
                      (COND
                         ((GREATERP NDEGREES 0)
                          0)                                 (* ; 

                                                        "sweep-flag: 0=counterclockwise, 1=clockwise")

                         (T 1))
                      DRAW-TO-X
                      (\HTML.SVG-Y
 DATA DRAW-TO-Y)
                      (\HTML-SVG-FG-COLOR DATA)
                      (\HTML.SVG-BRUSH-WIDTH
 BRUSH)
                      (\HTML.SVG-STROKE-DASHARRAY
 DASHING))
               (HTML.MOVETO
 STREAM DRAW-TO-X DRAW-TO-Y))))

(CL:DEFUN HTML.FILLCIRCLE
 (STREAM CENTERX CENTERY RADIUS TEXTURE)

   (* ;; "TODO implement TEXTURE")


   (with-htmldata
 (DATA STREAM)
          (HTML.OUTPUT-GRAPHICS
 STREAM)
          (LET ((BACKING (\HTML-BACKING-STREAM DATA)))
               (CL:FORMAT BACKING 
          "<circle cx=%"~d%" cy=%"~d%" r=%"~d%" fill=%"~a%" stroke=%"black%" stroke-width=%"1%"/>~%%"
                      CENTERX (\HTML.SVG-Y
 DATA CENTERY)
                      RADIUS
                      (\HTML-SVG-FG-COLOR DATA)))
          (HTML.MOVETO
 STREAM CENTERX CENTERY)))

(CL:DEFUN HTML.FILLPOLYGON
 (STREAM POINTS TEXTURE OPERATION WINDING-NUMBER)
   "Fill a closed polygon"

   (* ;; "TODO implement TEXTURE, OPERATION")


   (HTML.OUTPUT-GRAPHICS
 STREAM)
   (with-htmldata
 (DATA STREAM)
          (LET [(BACKING (\HTML-BACKING-STREAM DATA))
                (FILL-RULE (COND
                              ((ZEROP WINDING-NUMBER)
                               "nonzero")
                              (T "evenodd"]
               (CL:FORMAT BACKING 
                      "<polygon fill='~a' fill-rule='~A' stroke='black' stroke-width='1' points='"
                      (\HTML-SVG-FG-COLOR DATA)
                      FILL-RULE)
               [for
 POINT in
 POINTS do
 (CL:FORMAT BACKING "~d,~d " (CAR POINT)
                                              (\HTML.SVG-Y
 DATA (CDR POINT]
               (CL:FORMAT BACKING "'/>~%%"))))

(CL:DEFUN HTML.FONT
 (STREAM NEW-FONT)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-FONT DATA)))
               [COND
                  (NEW-FONT                                  (* ; "NEW-FONT might be a FONTDESCRIPTOR, a FONTCLASS, or a list of properties to apply to the current FONTDESCRIPTOR")

                         (SETQ NEW-FONT (OR (FONTCREATE (\HTML.COERCE-FONT
 NEW-FONT))
                                            (FONTCREATE OLD-VALUE NIL NIL NIL 
                                                   HTML.FONTCREATE.DEVICENAME T)
                                            (ERROR "Font not found or illegal parameter")))
                         (CL:WHEN (NEQ OLD-VALUE NEW-FONT)
                             (CL:SETF (\HTML-FONT DATA)
                                    NEW-FONT)
                             (CL:SETF (\HTML-LINEFEED DATA)
                                    (FONTPROP NEW-FONT 'HEIGHT))
                             (HTML.OUTPUT-GRAPHICS
 STREAM))]
               OLD-VALUE)))

(CL:DEFUN HTML.LEFTMARGIN
 (STREAM NEW-LEFT-MARGIN)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-LEFT-MARGIN DATA)))
               (COND
                  (NEW-LEFT-MARGIN (CL:SETF (\HTML-LEFT-MARGIN DATA)
                                          NEW-LEFT-MARGIN)))
               OLD-VALUE)))

(CL:DEFUN HTML.LINEFEED
 (STREAM NEW-DELTA)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-LINEFEED DATA)))
               (COND
                  ((AND NEW-DELTA (NOT (EQP OLD-VALUE NEW-DELTA)))
                   (CL:SETF (\HTML-LINEFEED DATA)
                          NEW-DELTA)
                   (HTML.OUTPUT-GRAPHICS
 STREAM)))
               OLD-VALUE)))

(CL:DEFUN HTML.MOVETO
 (STREAM X Y)
   "Move to X, Y"
   (with-htmldata
 (DATA STREAM)
          (CL:UNLESS (AND (EQP X (\HTML-X-POSITION DATA))
                          (EQP Y (\HTML-Y-POSITION DATA)))
              (CL:SETF (\HTML-X-POSITION DATA)
                     X)
              (CL:SETF (\HTML-Y-POSITION DATA)
                     Y)
              (HTML.OUTPUT-GRAPHICS
 STREAM))))

(CL:DEFUN HTML.NEWPAGE
 (STREAM)
   (with-htmldata
 (DATA STREAM)
          (\HTML.END-PAGE
 DATA STREAM)))

(CL:DEFUN HTML.OPERATION
 (STREAM NEW-OPERATION)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-IMAGE-OPERATION DATA)))
               (COND
                  (NEW-OPERATION (CL:SETF (\HTML-IMAGE-OPERATION DATA)
                                        NEW-OPERATION)))
               OLD-VALUE)))

(CL:DEFUN HTML.OUTCHARFN
 (STREAM CHCODE)
   "Write a character, which may cause us to write other markup first"
   [with-htmldata

    (DATA STREAM)
    (LET [(BACKING (\HTML-BACKING-STREAM DATA))
          (FONT-INFO (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 (\HTML-FONT DATA]
         (if
 (NOT (XTOUCODE? CHCODE))                        (* ; 

                                                       "if unmapped, write *XCCS-UNDEFINED-CHARCODE*")

             then
 (SETQ CHCODE *XCCS-UNDEFINED-CHARCODE*)
                  [LET* ((CHAR-WIDTH (\HTMLFONT-SLUG-WIDTH FONT-INFO))
                         (NEW-X-POSITION (+ (\HTML-X-POSITION DATA)
                                            CHAR-WIDTH)))
                        (CL:FLET ((SLUG-OUT NIL (HTML.OUTPUT-TEXT
 STREAM)
                                         (\OUTCHAR BACKING CHCODE)))
                               (if
 (> NEW-X-POSITION (\HTML-RIGHT-MARGIN DATA))
                                   then
 (HTML.TERPRI
 STREAM)
                                        (SLUG-OUT)
                                        (CL:INCF (\HTML-X-POSITION DATA)
                                               CHAR-WIDTH)
                                 else
 (SLUG-OUT)
                                      (CL:SETF (\HTML-X-POSITION DATA)
                                             NEW-X-POSITION]
           else
 
                (* ;; "Deal with real (mapped) characters")


                (LET ((CHARSET (\CHARSET CHCODE))
                      (CHAR8CODE (\CHAR8CODE CHCODE)))
                     (SELECTC CHCODE
                         ((CHARCODE ^J)                      (* ; "handle LF")

                              (HTML.TERPRI
 STREAM))
                         ((CHARCODE ^M)                      (* ; "handle CR")

                              (HTML.TERPRI
 STREAM))
                         ((CHARCODE ^L)                      (* ; "handle pagefeed")

                              (HTML.NEWPAGE
 STREAM))
                         ((CHARCODE SPACE)                   (* ; "handle spacefactor")

                              [LET ((SPACE-FACTOR (\HTML-SPACE-FACTOR DATA))
                                    (CHAR-WIDTH (\HTML.CHARWIDTH
 STREAM CHCODE)))
                                   (if
 (= SPACE-FACTOR 1)    (* ; "do normal stuff")

                                       then
 (LET ((NEW-X-POSITION (+ (\HTML-X-POSITION DATA)
                                                                     CHAR-WIDTH)))
                                                 (if
 (> NEW-X-POSITION (\HTML-RIGHT-MARGIN DATA))
                                                     then
 (HTML.TERPRI
 STREAM))
                                                 (CL:INCF (\HTML-X-POSITION DATA)
                                                        CHAR-WIDTH)
                                                 (HTML.OUTPUT-TEXT
 STREAM)
                                                 (\OUTCHAR BACKING CHCODE))
                                     else
 (LET [(NEW-X-POSITION (+ (\HTML-X-POSITION DATA)
                                                                   (FTIMES SPACE-FACTOR CHAR-WIDTH]
                                               (HTML.MOVETO
 STREAM NEW-X-POSITION (\HTML-Y-POSITION
                                                                                   DATA])
                         ((CHARCODE TAB)                     (* ; "handle TAB")

                              (LET [(NEW-X-POSITION (+ (\HTML-X-POSITION DATA)
                                                       (\HTML.TAB-DELTA-X
 DATA]
                                   [if
 (> NEW-X-POSITION (\HTML-RIGHT-MARGIN DATA))
                                       then
 (HTML.TERPRI
 STREAM)
                                            (SETQ NEW-X-POSITION (IPLUS (\HTML-X-POSITION DATA)
                                                                        (\HTML.TAB-DELTA-X
 DATA]
                                   (HTML.MOVETO
 STREAM NEW-X-POSITION (\HTML-Y-POSITION DATA))))
                         (LET* ((CHAR-WIDTH (\HTML.CHARWIDTH
 STREAM CHCODE))
                                (NEW-X-POSITION (+ (\HTML-X-POSITION DATA)
                                                   CHAR-WIDTH)))
                               (CL:FLET [(OUT NIL (HTML.OUTPUT-TEXT
 STREAM)

                                              (* ;; 

                                              "probably no need to encode >, but just in case...")


                                              (SELECTC CHCODE
                                                  ((CHARCODE &) 
                                                       (CL:FORMAT BACKING "&amp;"))
                                                  ((CHARCODE <) 
                                                       (CL:FORMAT BACKING "&lt;"))
                                                  ((CHARCODE >) 
                                                       (CL:FORMAT BACKING "&gt;"))
                                                  (\OUTCHAR BACKING CHCODE]
                                      (if
 (> NEW-X-POSITION (\HTML-RIGHT-MARGIN DATA))
                                          then
 (HTML.TERPRI
 STREAM)
                                               (OUT)
                                               (CL:INCF (\HTML-X-POSITION DATA)
                                                      CHAR-WIDTH)
                                        else
 (OUT)
                                             (CL:SETF (\HTML-X-POSITION DATA)
                                                    NEW-X-POSITION])

(CL:DEFUN HTML.RESET
 (STREAM)
   (with-htmldata
 (DATA STREAM)
          (AND NIL (CL:SETF (\HTML-X-POSITION DATA)
                          (\HTML-LEFT-MARGIN DATA)))
          (CL:SETF (\HTML-Y-POSITION DATA)
                 (\HTML-TOP-MARGIN DATA))
          (CL:SETF (\HTML-STATE DATA)
                 HTML.STATE.NON-TEXT-OUTPUT)))

(CL:DEFUN HTML.RIGHTMARGIN
 (STREAM NEW-RIGHT-MARGIN)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-RIGHT-MARGIN DATA)))
               (COND
                  (NEW-RIGHT-MARGIN (CL:SETF (\HTML-RIGHT-MARGIN DATA)
                                           NEW-RIGHT-MARGIN)))
               OLD-VALUE)))

(CL:DEFUN HTML.SCALE
 (STREAM NEW-SCALE)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-SCALE DATA)))
               [COND
                  (NEW-SCALE (printout T "Warning: DSPSCALE argument is ignored")
                         (DO-NOT
 (CL:SETF (\HTML-SCALE DATA)
                                        NEW-SCALE]
               OLD-VALUE)))

(CL:DEFUN HTML.SCALEDBITBLT
 (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT 
                                   DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE 
                                   CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM SCALE)

   (* ;; 

   "just like bitblt, but scale the image by SCALE. this is called by HTML.BITBLT with SCALE = 1")


   (with-htmldata
 (DATA STREAM)
          (HTML.OUTPUT-GRAPHICS
 STREAM)
          (LET [(BACKING (\HTML-BACKING-STREAM DATA))
                (NEW-WIDTH (TIMES SCALE (- WIDTH SOURCELEFT)))
                (NEW-HEIGHT (TIMES SCALE (- HEIGHT SOURCEBOTTOM]
               [CL:FORMAT BACKING 
                      "<image width='~d' height='~d' x='~d' y='~d' href='data:image/png;base64,"
                      (P-TO-CP
 NEW-WIDTH)
                      (P-TO-CP
 NEW-HEIGHT)
                      (OR DESTINATIONLEFT (DSPXPOSITION NIL STREAM))
                      (\HTML.SVG-Y
 DATA (+ (OR DESTINATIONBOTTOM (DSPYPOSITION NIL STREAM))
                                           (P-TO-CP
 NEW-HEIGHT)))
                      (OR DESTINATIONBOTTOM (- (DSPYPOSITION NIL STREAM)
                                               (P-TO-CP
 NEW-HEIGHT]
               (WRITE-BASE64-PNG
 BACKING SOURCEBITMAP SOURCELEFT SOURCEBOTTOM WIDTH HEIGHT)
               (CL:FORMAT BACKING "'/>~%%"))))

(CL:DEFUN HTML.SPACEFACTOR
 (STREAM NEW-FACTOR)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-SPACE-FACTOR DATA)))
               (COND
                  (NEW-FACTOR (CL:SETF (\HTML-SPACE-FACTOR DATA)
                                     NEW-FACTOR)))
               OLD-VALUE)))

(CL:DEFUN HTML.TERPRI
 (STREAM)
   "Do a newline"
   [with-htmldata
 (DATA STREAM)
          (LET ((BACKING (\HTML-BACKING-STREAM DATA)))
               (CL:SETF (\HTML-X-POSITION DATA)
                      (\HTML-LEFT-MARGIN DATA))
               (CL:DECF (\HTML-Y-POSITION DATA)
                      (\HTML-LINEFEED DATA))

               (* ;; "if Y-POSITION overflowed BOTTOM-MARGIN, start a new page")


               (if
 (< (\HTML-Y-POSITION DATA)
                      (\HTML-BOTTOM-MARGIN DATA))
                   then
 (\HTML.END-PAGE
 DATA STREAM)
                 else
 (HTML.OUTPUT-GRAPHICS
 STREAM])

(CL:DEFUN HTML.TOPMARGIN
 (STREAM NEW-TOP-MARGIN)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-TOP-MARGIN DATA)))
               (COND
                  (NEW-TOP-MARGIN (CL:SETF (\HTML-TOP-MARGIN DATA)
                                         NEW-TOP-MARGIN)))
               OLD-VALUE)))

(CL:DEFUN HTML.XPOSITION
 (STREAM NEW-X-POSITION)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-X-POSITION DATA)))
               (CL:WHEN (AND NEW-X-POSITION (NOT (EQP NEW-X-POSITION OLD-VALUE)))
                   (CL:SETF (\HTML-X-POSITION DATA)
                          NEW-X-POSITION)
                   (HTML.OUTPUT-GRAPHICS
 STREAM))
               OLD-VALUE)))

(CL:DEFUN HTML.YPOSITION
 (STREAM NEW-Y-POSITION)
   (with-htmldata
 (DATA STREAM)
          (LET ((OLD-VALUE (\HTML-Y-POSITION DATA)))
               (CL:WHEN (AND NEW-Y-POSITION (NOT (EQP NEW-Y-POSITION OLD-VALUE)))
                   (CL:SETF (\HTML-Y-POSITION DATA)
                          NEW-Y-POSITION)
                   (HTML.OUTPUT-GRAPHICS
 STREAM))
               OLD-VALUE)))

(CL:DEFUN MAKE-HTML-IMAGETYPE
 ()
   "Return the IMAGETYPE descriptor for HTML streams."
   `((OPENSTREAM OPENHTMLSTREAM)
     (FONTCREATE \HTML.FONTCREATE)
     (FONTSAVAILABLE \HTML.FONTSAVAILABLE)
     (CREATECHARSET \HTML.CREATECHARSET)
     (FONTEXISTS? \HTML.FONTEXISTS?)))

(CL:DEFUN \HTML.INIT-IMAGEDATA
 (HTMLSTREAM FONT)
   "Finish initializing the stream's IMAGEDATA"
   [with-htmldata
 (DATA HTMLSTREAM)

          (* ;; "set the font and linefeed delta")


          (CL:SETF (\HTML-FONT DATA)
                 FONT)
          (CL:SETF (\HTML-LINEFEED DATA)
                 (FONTPROP FONT 'HEIGHT))

          (* ;; "set the margins")


          (CL:SETF (\HTML-LEFT-MARGIN DATA)
                 0)
          (CL:SETF (\HTML-RIGHT-MARGIN DATA)
                 (\HTML-PAGE-WIDTH DATA))
          [CL:SETF (\HTML-TOP-MARGIN DATA)
                 (- (\HTML-PAGE-HEIGHT DATA)
                    (FONTPROP FONT 'HEIGHT]
          (CL:SETF (\HTML-BOTTOM-MARGIN DATA)
                 0)
          (CL:SETF (\HTML-Y-POSITION DATA)
                 (\HTML-TOP-MARGIN DATA))
          (CL:SETF (\HTML-CLIPPING-REGION DATA)
                 (CREATEREGION (\HTML-LEFT-MARGIN DATA)
                        (\HTML-BOTTOM-MARGIN DATA)
                        (\HTML-PAGE-WIDTH DATA)
                        (\HTML-PAGE-HEIGHT DATA])

(CL:DEFUN \HTMLSTREAM.INIT
 ()

   (* ;; "Initialize the HTMLSTREAM world")


   (DECLARE
 (GLOBALVARS \HTMLSTREAM.FDEV IMAGESTREAMTYPES *DEFAULT-EXTERNALFORMAT*))
   (SETQ \HTMLSTREAM.FDEV (create
 FDEV
                                 DEVICENAME _ (LIST HTML.FONTCREATE.DEVICENAME 'DOCUMENT)
                                 CLOSEFILE _ #'NILL
                                 BOUT _ #'NILL))

   (* ;; "update IMAGESTREAMTYPES")


   (PUTASSOC HTML.FONTCREATE.DEVICENAME (MAKE-HTML-IMAGETYPE
)
          IMAGESTREAMTYPES)

   (* ;; "set up font definitions")


   (COND
      (*HTML-ADD-FONT-DEFS* (DEFAULTFONT 'HTML '(NOTO-SANS 10 MRR))
             (\HTML.ADD-FONT-DEFS
))))

(CL:DEFUN WRITE-BASE64-PNG
 (STREAM BITMAP SOURCELEFT SOURCEBOTTOM WIDTH HEIGHT)
   "Write a BASE64-encoded PNG rendition of the bitmap, clipped as directed"
   (CONVERT-TO-PNG-BASE64
 BITMAP SOURCELEFT SOURCEBOTTOM WIDTH HEIGHT STREAM))

(CL:DEFUN CONVERT-TO-PNG-BASE64
 (BITMAP SOURCELEFT SOURCEBOTTOM WIDTH HEIGHT STREAM)
   "Write a bitmap as a BASE64-encoded PNG stream"

   (* ;; "We encode the PNG as BASE64 using a GENERATOR to produce and ENCODE-BASE64-GEN to consume")


   (LET ((THRESHOLD (/ (BITSPERPIXEL BITMAP)
                       2)))
        (S-BASE64:ENCODE-BASE64-GEN (GENERATOR (UNCOMPRESSED-PNG:WRITE-BITMAP
                                                BITMAP THRESHOLD SOURCELEFT SOURCEBOTTOM WIDTH HEIGHT
                                                NIL #'(CL:LAMBDA (BYTE)
                                                             (PRODUCE BYTE))
                                                #'UNCOMPRESSED-PNG:PIXEL-TO-MONOCHROME-RGBA))
               STREAM)))

(CL:DEFUN URL-ENCODE
 (STRING)
   (LET ((RESULT (CL:MAKE-ARRAY 0 :FILL-POINTER 0 :ADJUSTABLE T)))
        [CL:LOOP FOR CHAR ACROSS STRING DO (COND
                                              ((OR (CL:ALPHANUMERICP CHAR)
                                                   (CL:CHAR-EQUAL CHAR #\-)
                                                   (CL:CHAR-EQUAL CHAR #\_)
                                                   (CL:CHAR-EQUAL CHAR #\.)
                                                   (CL:CHAR-EQUAL CHAR #\~))
                                               (CL:VECTOR-PUSH-EXTEND CHAR RESULT))
                                              ((CL:CHAR-EQUAL CHAR #\Space)
                                               (CL:VECTOR-PUSH-EXTEND #\+ RESULT))
                                              (T (CL:VECTOR-PUSH-EXTEND #\% RESULT)
                                                 (CL:LOOP FOR C ACROSS 
                                                             (* ; "hex")

                                                        (CL:FORMAT NIL "~2,'0x" (CL:CHAR-INT CHAR))
                                                        DO
                                                        (CL:VECTOR-PUSH-EXTEND C RESULT]
        (COERCE RESULT 'STRING)))

(CL:DEFUN HTML-ENCODE
 (STRING)
   (LET ((RESULT (CL:MAKE-ARRAY 0 :FILL-POINTER 0 :ADJUSTABLE T)))
        [CL:LOOP FOR CHAR ACROSS STRING DO (COND
                                              ((OR (CL:CHAR-EQUAL CHAR #\>)
                                                   (CL:CHAR-EQUAL CHAR #\<)
                                                   (CL:CHAR-EQUAL CHAR #\&))
                                               (CL:VECTOR-PUSH-EXTEND #\& RESULT)
                                               (CL:VECTOR-PUSH-EXTEND #\# RESULT)
                                               (CL:VECTOR-PUSH-EXTEND #\x RESULT)
                                               (CL:LOOP FOR C ACROSS 
                                                             (* ; "hex")

                                                      (CL:FORMAT NIL "~4,'0x" (CL:CHAR-INT CHAR))
                                                      DO
                                                      (CL:VECTOR-PUSH-EXTEND C RESULT))
                                               (CL:VECTOR-PUSH-EXTEND #\; RESULT))
                                              (T (CL:VECTOR-PUSH-EXTEND CHAR RESULT]
        (COERCE RESULT 'STRING)))

(CL:DEFVAR *HTML-DEBUG-FONTCREATE*
 NIL
   "Set to T to make the font creation machinery log what it's doing")

(CL:DEFPARAMETER *HTML-FONT-METRIC-BASIS*
 'CHARSET0 "Do we change the font's ascent & descent as we load charsets (RECALC) or always use charset 0 (CHARSET0)?"
)

(CL:DEFUN \HTML.FONTCREATE
 (FONTSPEC)
   "Create a font for the HTML device"
   (DECLARE
 (GLOBALVARS \DEFAULTCHARSET))
   (\HTML-DBG
 "\HTML.FONTCREATE ~a~%%" FONTSPEC)
   (if
 (NEQ (fetch
 FSDEVICE of
 FONTSPEC)
            HTML.FONTCREATE.DEVICENAME)
       then
 (ERROR "Calling \HTML.FONTCREATE on a non-HTML fontspec"))
   [LET* ((ORIGINAL-FAMILY (fetch
 (FONTSPEC FSFAMILY) of
 FONTSPEC))
          (COERCED-FONT-SPEC (\HTML.COERCE-OR-IDENTITY
 FONTSPEC))
          (FAMILY (fetch
 (FONTSPEC FSFAMILY) of
 COERCED-FONT-SPEC))
          (SIZE (fetch
 (FONTSPEC FSSIZE) of
 COERCED-FONT-SPEC))
          (FACE (fetch
 (FONTSPEC FSFACE) of
 COERCED-FONT-SPEC))
          (ROTATION (fetch
 (FONTSPEC FSROTATION) of
 COERCED-FONT-SPEC))
          (DEVICE (fetch
 (FONTSPEC FSDEVICE) of
 COERCED-FONT-SPEC))
          (CHARSET \DEFAULTCHARSET))
         (if
 (NEQ ROTATION 0)
             then
 (ERROR "We only support ROTATION = 0"))
         (LET [(FONT-DESCR (for
 DIR METRICS in
 HTMLFONTDIRECTORIES
                              when
 (SETQ METRICS (\HTML.READ-FONT-METRICS
 FAMILY FACE SIZE DIR))
                              do
 (RETURN METRICS]
              [COND
                 ((NULL FONT-DESCR)
                  (ERROR "Could not find font metrics" (LIST FAMILY SIZE FACE]
              (LET* [(SLUG-WIDTH (fetch
 (WEB-FONT-DESCR :SLUG-WIDTH) of
 FONT-DESCR))
                     (PRIVATE-FONT-INFO (MAKE-HTML.FONTINFO :SLUG-WIDTH SLUG-WIDTH :CHARSETS
                                               (MAKE-CHARSET-BIT-ARRAY
 (fetch
 (WEB-FONT-DESCR 
                                                                                     :CHARSETS)
                                                                          of
 FONT-DESCR))
                                               :CSS-CLASS
                                               (CSS-CLASS-FROM
 FAMILY SIZE FACE]
                    (COND
                       ((NEQ ORIGINAL-FAMILY FAMILY)
                        (\HTML-DBG
 "Coerced ~A to ~A~%%" ORIGINAL-FAMILY FAMILY)))

                    (* ;; "read the metrics for charset CHARSET")


                    (LET [(CHARSET-DESCR (for
 DIR METRICS in
 HTMLFONTDIRECTORIES
                                            when
 (SETQ METRICS (\HTML.READ-CHARSET-METRICS
 FAMILY 
                                                                      SIZE FACE CHARSET DIR))
                                            do
 (RETURN METRICS]
                         [COND
                            ((NOT CHARSET-DESCR)
                             (ERROR "Could not find charset metrics" (LIST FAMILY SIZE FACE CHARSET]
                         (LET* ((CHARSET0-WIDTHS (fetch
 (WEB-CHARSET-METRICS :WIDTHS) of
 
                                                                                        CHARSET-DESCR
                                                        ))
                                (FD (create
 FONTDESCRIPTOR
                                           FONTDEVICE _ DEVICE
                                           FONTSCALE _ *CENTIPOINTS-PER-POINT*
                                           FONTFAMILY _ FAMILY
                                           FONTSIZE _ SIZE
                                           FONTFACE _ FACE
                                           \SFAscent _ (fetch
 (WEB-FONT-METRICS :MAX-ASCENT)
                                                          of
 FONT-DESCR)
                                           \SFDescent _ (fetch
 (WEB-FONT-METRICS :MAX-DESCENT)
                                                           of
 FONT-DESCR)
                                           \SFHeight _ (fetch
 (WEB-FONT-METRICS :HEIGHT) of
 
                                                                                           FONT-DESCR
                                                              )
                                           ROTATION _ 0
                                           FONTSLUGWIDTH _ SLUG-WIDTH
                                           FONTDEVICESPEC _ FONTSPEC
                                           \SFFACECODE _ (\FACECODE FACE)
                                           OTHERDEVICEFONTPROPS _ PRIVATE-FONT-INFO))
                                (CSINFO (\CREATECHARSET CHARSET FD))
                                (CS-WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)))
                               (replace
 (CHARSETINFO CHARSETASCENT) of
 CSINFO
                                  with
 (fetch
 (WEB-CHARSET-METRICS :MAX-ASCENT) of
 CHARSET-DESCR))
                               (replace
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO
                                  with
 (fetch
 (WEB-CHARSET-METRICS :MAX-DESCENT) of
 CHARSET-DESCR))
                               (for
 WIDTH in
 CHARSET0-WIDTHS as
 CH from
 0 to
 \MAXTHINCHAR
                                  do
 (CL:UNLESS (NULL WIDTH)
                                            (\FSETWIDTH CS-WIDTHS CH WIDTH)))

                               (* ;; "copy slug charset widths to charsets vector #256")


                               (\BUILDSLUGCSINFO FD SLUG-WIDTH)
                               FD])

(CL:DEFUN \HTML.FONTEXISTS?
 (FONTSPEC)
   "If the font exists, return the file name of the WFM file."
   [LET* ((FAMILY (fetch
 (FONTSPEC FSFAMILY) of
 FONTSPEC))
          (SIZE (fetch
 (FONTSPEC FSSIZE) of
 FONTSPEC))
          (FACE (fetch
 (FONTSPEC FSFACE) of
 FONTSPEC))
          (WEIGHT (fetch
 (WEB-FONT-FACE :WEIGHT) of
 FACE))
          (SLOPE (fetch
 (WEB-FONT-FACE :SLOPE) of
 FACE))
          (EXPANSION (fetch
 (WEB-FONT-FACE :EXPANSION) of
 FACE)))
         (for
 DIR FILE-NAME in
 HTMLFONTDIRECTORIES
            thereis
 (INFILEP (PACKFILENAME.STRING 'DIRECTORY DIR 'NAME
                                    (MAKE-FONT-METRICS-FILE-NAME
 FAMILY SIZE WEIGHT SLOPE EXPANSION])

(CL:DEFUN \HTML.FONTSAVAILABLE
 (FAMILY SIZE FACE ROTATION DEVICE)
   "Search for matching fonts for the HTML device"

   (* ;; "any of the fields can be '*.  Ignore ROTATION. FACE = (WEIGHT SLOPE EXPANSION)")


   (* ;; "return a list of fontspecs")


   [LET* ((FACE-AS-LIST (\FONTFACE FACE))
          (WEIGHT (fetch
 (FONTFACE WEIGHT) of
 FACE-AS-LIST))
          (SLOPE (fetch
 (FONTFACE SLOPE) of
 FACE-AS-LIST))
          (EXPANSION (fetch
 (FONTFACE EXPANSION) of
 FACE-AS-LIST))
          (FILE-NAME (MAKE-FONT-METRICS-FILE-NAME
 FAMILY SIZE WEIGHT SLOPE EXPANSION)))
         (LET [(MATCHING-FILES (for
 DIR in
 HTMLFONTDIRECTORIES
                                  thereis
 (LET ((PATTERN (PACKFILENAME.STRING 'BODY DIR 'NAME 
                                                                FILE-NAME)))
                                               (DIRECTORY PATTERN]
              [COND
                 ((NULL MATCHING-FILES)
                  (ERROR "Could not find font" (LIST FAMILY SIZE FACE ROTATION]
              (FOR
 MATCH IN
 MATCHING-FILES 

                            (* ;; 

                            "the name will look like <font name>-<size>-<weight>-<slope>-<expansion>")


                            (* ;; 

                            "<font name> may contain hyphens, so parse from the end to the beginning")


                            
                 COLLECT
 (LET* ((MATCHING-NAME (UNPACKFILENAME.STRING MATCH 'NAME))
                                (EXPANSION-POS (STRPOS "-" MATCHING-NAME NIL NIL NIL NIL NIL T))
                                (SLOPE-POS (STRPOS "-" MATCHING-NAME (CL:1- EXPANSION-POS)
                                                  NIL NIL NIL NIL T))
                                (WEIGHT-POS (STRPOS "-" MATCHING-NAME (CL:1- SLOPE-POS)
                                                   NIL NIL NIL NIL T))
                                (SIZE-POS (STRPOS "-" MATCHING-NAME (CL:1- WEIGHT-POS)
                                                 NIL NIL NIL NIL T)))
                               (LIST (MKATOM (SUBSTRING MATCHING-NAME 1 (CL:1- SIZE-POS)))
                                     (MKATOM (SUBSTRING MATCHING-NAME (CL:1+ SIZE-POS)
                                                    (CL:1- WEIGHT-POS)))
                                     [LIST (MKATOM (SUBSTRING MATCHING-NAME (CL:1+ WEIGHT-POS)
                                                          (CL:1- SLOPE-POS)))
                                           (MKATOM (SUBSTRING MATCHING-NAME (CL:1+ SLOPE-POS)
                                                          (CL:1- EXPANSION-POS)))
                                           (MKATOM (SUBSTRING MATCHING-NAME (CL:1+ EXPANSION-POS]
                                     0 HTML.FONTCREATE.DEVICENAME])

(CL:DEFUN HTMLFONT.GETCHARSET
 (STREAM CHARSET FONT)
   "Return the CHARSETINFO for CHARSET from STREAM"

   (* ;; "set CSINFO to the charsetinfo")


   (* ;; "If open, assume it's a charset metrics stream, that the initial version expr has been checked, and we are positioned after that.  FONT is provided so we can update the fontdescriptor.")


   (\HTML-DBG
 "HTMLFONT.GETCHARSET ~a c~o ~a~%%" STREAM CHARSET FONT)
   (CL:UNLESS (<= 0 CHARSET \MAXCHARSET)
          (\ILLEGAL.ARG CHARSET))
   [LET ((*PACKAGE* (CL:FIND-PACKAGE "IL"))
         (CLOSE-STREAM NIL))
        (CL:UNWIND-PROTECT
            (PROGN 
                   (* ;; "If we're opening it, check the format and remember to close it later")


                   (CL:UNLESS (\GETSTREAM STREAM 'INPUT T)
                       (SETQ STREAM (OPENSTREAM STREAM 'INPUT))
                       (SETQ CLOSE-STREAM T)

                       (* ;; "check it")


                       (CHECK-BROWSER-METRICS-FORMAT
 (READ STREAM)))

                   (* ;; "read and interpret it")


                   (LET* ((CHARSET-DESCR (READ STREAM))
                          (CHARSET-WIDTHS (fetch
 (WEB-CHARSET-METRICS :WIDTHS) of
 CHARSET-DESCR))
                          (ASCENT (fetch
 (WEB-CHARSET-METRICS :MAX-ASCENT) of
 CHARSET-DESCR))
                          (DESCENT (fetch
 (WEB-CHARSET-METRICS :MAX-DESCENT) of
 CHARSET-DESCR))
                          (CSINFO (create
 CHARSETINFO
                                         CHARSETNO _ CHARSET
                                         CSCOMPLETEP _ T
                                         CHARSETASCENT _ ASCENT
                                         CHARSETDESCENT _ DESCENT))
                          (CS-WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)))
                         (CHARSETPROP CSINFO 'CSCHARENCODING 'MCCS)
                         (for
 WIDTH in
 CHARSET-WIDTHS as
 CH from
 0 to
 \MAXTHINCHAR
                            do
 (CL:WHEN WIDTH (\FSETWIDTH CS-WIDTHS CH WIDTH)))
                         (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO with
 CS-WIDTHS)

                         (* ;; "update FONT's ascent and descent?")


                         (if
 (EQ *HTML-FONT-METRIC-BASIS* 'CHARSET0) 
                                                             (* ; "old behavior, the default")

                             then
 (if
 (ZEROP CHARSET)        (* ; "get font metrics from charset 0")

                                      then
 (replace
 (FONTDESCRIPTOR \SFAscent) of
 FONT with
 ASCENT)
                                           (replace
 (FONTDESCRIPTOR \SFDescent) of
 FONT with
 DESCENT)
                                      )
                           else
                              (* ; "RECALC:")

                                                             (* ; "update as we load charsets")

                                (change
 (fetch
 (FONTDESCRIPTOR \SFAscent) of
 FONT)
                                       (IMAX DATUM ASCENT))
                                (change
 (fetch
 (FONTDESCRIPTOR \SFDescent) of
 FONT)
                                       (IMAX DATUM DESCENT)))
                         CSINFO))

            (* ;; "if this is the last charset in the font, mark the font as FONTCOMPLETEP")


            (MAYBE-MARK-FONT-COMPLETE
 FONT)
            (if
 CLOSE-STREAM
                then
 (CLOSEF? STREAM)))])

(CL:DEFUN HTMLFONT.FILEP
 (FILE)
   "Is the file in the expected charset metrics format?"

   (* ;; "Initial FORMAT s-expression distinguishes HTML font format from others.  This may be called after the first s-expr has been read; if not, we skip over it here.")


   (* ;; "For a valid file, returns (fullname date)")


   (* ;; "If FILE is an open stream, it is left open.  Otherwise it is opened and closed.")


   [LET (STREAM)
        (CL:UNWIND-PROTECT
            (LET (VERSION DATE)
                 [SETQ STREAM (if
 (\GETSTREAM FILE 'INPUT T)
                                  then
 FILE
                                else
 (OPENSTREAM FILE 'INPUT]
                 (SETFILEPTR STREAM 0)                       (* ; "go to start of file to read")

                 (LET ((VERSION (READ STREAM)))
                      (if
 (HTML-FONT-METRICS-VERSION-OK?
 VERSION)
                          then
 (LIST (FULLNAME STREAM)
                                     (GETFILEINFO STREAM 'CREATIONDATE))
                        else
 NIL)))

            (* ;; "if we opened the file, close it")


            (if
 (NOT (STREAMP FILE))
                then
 (CLOSEF? STREAM)))])

(CL:DEFUN \HTML.CREATECHARSET
 (FONTSPEC FONTDESC CHARSET)
   [OR (\READCHARSET FONTSPEC CHARSET FONTDESC)
       (\HTML-DBG
 "\HTML.CREATECHARSET ~a ~a c~o~%%" FONTSPEC FONTDESC CHARSET)
       (LET ((COERCED-FONTSPEC (\HTML.COERCE-OR-IDENTITY
 FONTSPEC)))
            (CL:WHEN COERCED-FONTSPEC
                (\HTML-DBG
 "\HTML.CREATECHARSET coerced ~a to ~a~%%" FONTSPEC COERCED-FONTSPEC)
                [LET ((PRIVATE-FONT-INFO (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 FONTDESC))
                      (FAMILY (fetch
 (FONTSPEC FSFAMILY) of
 COERCED-FONTSPEC))
                      (SIZE (fetch
 (FONTSPEC FSSIZE) of
 COERCED-FONTSPEC))
                      (FACE (fetch
 (FONTSPEC FSFACE) of
 COERCED-FONTSPEC))
                      (ROTATION (fetch
 (FONTSPEC FSROTATION) of
 COERCED-FONTSPEC)))
                     (COND
                        ((KNOWN-CHARSET?
 PRIVATE-FONT-INFO CHARSET)
                         (LET [(CHARSET-DESCR (for
 DIR METRICS in
 HTMLFONTDIRECTORIES
                                                 when
 (SETQ METRICS (\HTML.READ-CHARSET-METRICS

                                                                     FAMILY SIZE FACE CHARSET DIR))
                                                 do
 (RETURN METRICS]
                              [COND
                                 ((NOT CHARSET-DESCR)
                                  (ERROR "Could not find charset metrics" (LIST FAMILY SIZE FACE 
                                                                                CHARSET]
                              (LET* ((CHARSET-WIDTHS (fetch
 (WEB-CHARSET-METRICS :WIDTHS)
                                                        of
 CHARSET-DESCR))
                                     (CSINFO (create
 CHARSETINFO
                                                    CHARSETNO _ CHARSET
                                                    CSCOMPLETEP _ T
                                                    CHARSETASCENT _ (fetch
 (WEB-CHARSET-METRICS
                                                                            :MAX-ASCENT) of
 
                                                                                        CHARSET-DESCR
                                                                           )
                                                    CHARSETDESCENT _ (fetch
 (WEB-CHARSET-METRICS
                                                                             :MAX-DESCENT)
                                                                        of
 CHARSET-DESCR)))
                                     (CS-WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)))
                                    (for
 WIDTH in
 CHARSET-WIDTHS as
 CH from
 0 to
 \MAXTHINCHAR
                                       do
 (CL:WHEN WIDTH (\FSETWIDTH CS-WIDTHS CH WIDTH)))
                                    (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO with
 CS-WIDTHS)
                                    CSINFO)))
                        (T (PROGN (AND *HTML-DEBUG-FONTCREATE* (\HTML.WARN-CHARSET
 FONTDESC CHARSET T
                                                                      ))
                                  NIL])])

(CL:DEFUN \HTML.CHANGECHARSET
 (DATA CHARSET)
   "Set the new character set, creating the charset info if necessary"

   (* ;; "But don't change the charset if CHARSET is not a member of the font's charsets list")


   (printout T "\HTML.CHANGECHARSET " CHARSET T)
   (LET* ((FONT (\HTML-FONT DATA)))
         (CL:IF (KNOWN-CHARSET?
 (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 FONT)
                       CHARSET)
             (LET ((CSINFO (\HTML.CREATECHARSET
 (FONTPROP FONT 'FAMILY)
                                  (FONTPROP FONT 'SIZE)
                                  (FONTPROP FONT 'FACE)
                                  0 HTML.FONTCREATE.DEVICENAME CHARSET FONT T)))
                  (\INSTALLCHARSETINFO FONT CSINFO CHARSET))
             (printout T "Font does not contain charset " CHARSET T))))

(CL:DEFUN MAKE-CHARSET-BIT-ARRAY
 (CHARSETS-LIST)
   "Read a list of charset numbers and return an equivalent set in the form of a bit-vector"
   (LET ((BIT-SET (BITMAPCREATE (IPLUS 1 \MAXCHARSET)
                         1 1)))
        (CL:DOLIST (CHARSET CHARSETS-LIST)
            (BITMAPBIT BIT-SET CHARSET 0 1))
        BIT-SET))

(CL:DEFUN KNOWN-CHARSET?
 (HTMLFONT CHARSET)
   "Return T if the HTMLFONT says it has metrics for CHARSET"
   [LET ((KNOWN-CHARSETS (\HTMLFONT-CHARSETS HTMLFONT)))
        (NOT (ZEROP (BITMAPBIT KNOWN-CHARSETS CHARSET 0])

(CL:DEFUN \HTML.WARN-CHARSET
 (FONT CHARSET WARN-STREAM)
   "Warn the user once that the font doesn't support the charset"
   [LET ((PRIVATE-FONT-INFO (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 FONT)))
        (CL:UNLESS (FMEMB CHARSET (\HTMLFONT-WARNED-CHARSETS PRIVATE-FONT-INFO))
            (printout WARN-STREAM "Font " .PPVTL (FONTPROP FONT 'SPEC)
                   " does not support charset #o" .I3.8.T CHARSET " (" CHARSET ")" T)
            (CL:PUSH CHARSET (\HTMLFONT-WARNED-CHARSETS PRIVATE-FONT-INFO)))])

(CL:DEFUN \HTML.ADD-FONT-DEFS
 ()
   "Add HTML fonts to FONTDEFS and font profiles"
   (DECLARE
 (GLOBALVARS FONTVARS FONTDEFS))

   (* ;; "Add HTML fonts to FONTDEFS")


   [CL:LOOP :FOR FONTDEF :IN FONTDEFS :DO
          (CL:LOOP :FOR FP :IN (CDR (ASSOC 'FONTPROFILE (CDR FONTDEF)))
                 :DO
                 (CL:UNLESS (ASSOC 'HTML (CL:NTHCDR 5 FP))   (* ; 

                                                          "There's already an HTML spec, so leave it")

                     [NCONC1 FP `(HTML ,(OR (CL:FIFTH FP)
                                            (CL:FOURTH FP)
                                            (CL:THIRD FP])]

   (* ;; "Add them to all of the font vars")


   [LET ((DEFAULT-FONT (FONTCREATE 'NOTO-SANS 10 'MRR 0 HTML.FONTCREATE.DEVICENAME)))
        (CL:LOOP :FOR (FONTVAR)
               :IN FONTVARS :WHEN (AND (LITATOM FONTVAR)
                                       (NEQ FONTVAR '*))
               :DO
               (LET ((FONTCLASS (EVALV FONTVAR)))
                    (COND
                       ((EQ 'FONTCLASS (TYPENAME FONTCLASS))
                        (SETFONTCLASSCOMPONENT FONTCLASS HTML.FONTCREATE.DEVICENAME DEFAULT-FONT)
                        (DO-NOT
 (CL:FORMAT T "Updated FONTCLASS ~s~%%" FONTVAR)))
                       (T (DO-NOT
 (CL:FORMAT T "~s is not a FONTCLASS~%%" FONTCLASS])

(CL:DEFUN \FIRST-COERCION
 (COERCIONS)
   "Given a result from COERCEFONTSPEC, return the first FONTSPEC - which may be nested"
   (if
 (LISTP COERCIONS)
       then
 (LET ((FIRST-ELT (CAR COERCIONS)))
                 (if
 (LITATOM FIRST-ELT)
                     then
 COERCIONS
                   else
 (\FIRST-COERCION
 FIRST-ELT)))
     else
 (ERROR "This isn't a coercion result" COERCIONS)))

(CL:DEFUN \HTML.COERCE-OR-IDENTITY
 (FONTSPEC)
   "Coerce the fontspec to a fontspec we can use. If it's coerceable, return the coercion, else return the cleaned original if it exists. Otherwise return NIL."
   (LET* [(CLEAN-FONTSPEC (\FONT.CHECKARGS FONTSPEC NIL NIL NIL HTML.FONTCREATE.DEVICENAME))
          (EXISTS (FONTEXISTS? CLEAN-FONTSPEC NIL NIL NIL HTML.FONTCREATE.DEVICENAME T))
          (COERCED (COERCEFONTSPEC CLEAN-FONTSPEC 'FONTCOERCIONS]
         (\HTML-DBG
 "original ~a clean ~a exists ~a coerced ~a~%%" FONTSPEC CLEAN-FONTSPEC EXISTS 
                COERCED)
         (if
 COERCED
             then
 (\FIRST-COERCION
 COERCED)
           elseif
 EXISTS
             then
 CLEAN-FONTSPEC
           else
 NIL)))

(CL:DEFUN \HTML.COERCE-FONT
 (ORIGINAL-FONT)
   "Coerce the font or font spec to an HTML fontspec"
   (LET* [(FONTSPEC (COND
                       [(type?
 FONTCLASS ORIGINAL-FONT)
                        (CDR (ASSOC HTML.FONTCREATE.DEVICENAME (fetch
 (FONTCLASS OTHERFDS)
                                                                  of
 ORIGINAL-FONT]
                       (T (LET [(NEW-SPEC (FONTPROP ORIGINAL-FONT 'SPEC]

                               (* ;; 

                       "the original fontspec might be for a different device, so overwrite FSDEVICE")


                               (replace
 (FONTSPEC FSDEVICE) of
 NEW-SPEC with
 
                                                                           HTML.FONTCREATE.DEVICENAME
                                      )
                               NEW-SPEC]
         (\HTML.COERCE-OR-IDENTITY
 FONTSPEC)))

(CL:DEFUN MAYBE-MARK-FONT-COMPLETE
 (FONT)
   "If every charset is loaded, mark the font as FONTCOMPLETEP"
   (for
 CHARSET-INDEX from
 0 to
 \MAXCHARSET do
 (if
 (NULL (\GETCHARSETINFO FONT CHARSET-INDEX))
                                                   then
 (RETURN)))
   (replace
 (FONTDESCRIPTOR FONTCOMPLETEP) of
 FONT with
 T))



(* ;; "New Font World!")



(CL:DEFUN \HTML.FONTCREATE-NEW
 (FONTSPEC)
   "Create an empty FONTDESCRIPTOR with device set for HTML."
   (\HTML-DBG
 "\HTML.FONTCREATE-NEW ~a~%%" FONTSPEC)
   (create
 FONTDESCRIPTOR
          FONTDEVICE _ HTML.FONTCREATE.DEVICENAME
          FONTSCALE _ *CENTIPOINTS-PER-POINT*))

(\HTMLSTREAM.INIT
)



(* ;; "MEDLEYFONT-related utility")



(CL:DEFPARAMETER *HTML.ALL-GENERATED-FONT-SIZES*

   '(6 8 10 12 14 16 18 20 24 32 34 36 38 40 42 44 46 48 50 92))

(CL:DEFPARAMETER *HTML.ALL-GENERATED-FONT-FACES*
 '("mrr" "mir" "brr" "bir"))

(CL:DEFUN HTML.CREATE-MEDLEYFONT-FAMILY
 (FAMILY)
   "Call COMPLETE.FONT on every face and size of the font family for the HTML device"
   [for
 SIZE in
 *HTML.ALL-GENERATED-FONT-SIZES*
      do
 (for
 FACE in
 *HTML.ALL-GENERATED-FONT-FACES*
            do
 (LET* ((COMPLETE-FONT (COMPLETE.FONT (create
 FONTSPEC
                                                           FSFAMILY _ FAMILY
                                                           FSSIZE _ SIZE
                                                           FSFACE _ FACE
                                                           FSROTATION _ 0
                                                           FSDEVICE _ HTML.FONTCREATE.DEVICENAME)))
                      (NEW-FILE-NAME (MEDLEYFONT.WRITE.FONT COMPLETE-FONT)))
                     (CL:FORMAT T "Created ~a ~d ~a: ~a~%%" FAMILY SIZE FACE NEW-FILE-NAME])

(CL:DEFUN HTML.CREATE-ALL-MEDLEYFONT-FAMILIES
 ()
   "Generate MEDLEYHTMLFONTs for all font families"
   (for
 FAMILY in
 *HTML-STANDARD-PAGE-WEB-FONT-FAMILIES* do
 (HTML.CREATE-MEDLEYFONT-FAMILY
 FAMILY)))



(* ;; "PRINTFILETYPES-related")



(CL:DEFCONSTANT *HTML-FILE-EXTENSIONS*
 '("html" "htm")
                                       
                             "The file extensions that denote an HTML file. Case is not significant.")

(CL:DEFCONSTANT *HTML-FINGERPRINTS*
 '("<!DOCTYPE HTML" "<html")
                                    "If a file begins with any of these strings, it's an HTML file.")

(CL:DEFUN HTMLFILEP
 (FILE)
   "Is the FILE an HTML file?"

   (* ;; "Check the extension; failing that, look at the start of the file")


   [LET [(EXTENSION (L-CASE (UNPACKFILENAME.STRING FILE 'EXTENSION]
        (if
 (MEMBER EXTENSION *HTML-FILE-EXTENSIONS*)
            then
 T
          else
 (CL:WITH-OPEN-STREAM
                (STREAM (OPENSTREAM FILE 'INPUT NIL))

                (* ;; "check if the file starts with any of the members of *HTML-FINGERPRINTS*")


                (LET ((FIRST-CHAR-OR-NIL (SKIPSEPRS STREAM)))
                     (if
 (NULL FIRST-CHAR-OR-NIL)
                         then
 NIL
                       else
 (LET [(FIRST-LINE (L-CASE (CL:READ-LINE STREAM]

                                 (* ;; 

                                 "see if it starts with any of the elements of *HTML-FINGERPRINTS*")


                                 (AND (for
 FINGERPRINT in
 *HTML-FINGERPRINTS*
                                         thereis
 (= 1 (STRPOS (L-CASE FINGERPRINT)
                                                             FIRST-LINE NIL NIL T)))
                                      T])

(CL:DEFUN MAKE-HTML-FROM-TEXT
 (FILE HTMLFILE FONTS HEADING TABS)
   (TEXTTOIMAGEFILE FILE HTMLFILE HTML.IMAGETYPE FONTS HEADING TABS NIL))

(CL:DEFUN MAKE-HTML-FROM-TEDIT
 (FILE HTMLFILE)

   (* ;; "Make an HTML file from a TEdit document.  If FILE is a string, make it into a symbol for the file-name.  If it's a STREAM, use that stream.")


   [COND
      ((STRINGP FILE)
       (SETQ FILE (MKATOM FILE]
   (SETQ FILE (OPENTEXTSTREAM FILE))
   (TEDIT.FORMAT.HARDCOPY FILE HTMLFILE T NIL NIL NIL HTML.IMAGETYPE)
   (CLOSEF? FILE)
   HTMLFILE)

(ADDTOVAR PRINTFILETYPES
 (HTML (TEST HTMLFILEP)
                               (EXTENSION (HTML))
                               (CONVERSION (TEXT MAKE-HTML-FROM-TEXT TEDIT MAKE-HTML-FROM-TEDIT))))

(ADDTOVAR FB.SEE.METHODS
 (HTMLFILEP ShellOpen))



(* ;; "debugging support")



(CL:DEFUN \CLEAN-FONT-CACHE
 ()
   "Remove all HTML fonts from all caches"
   (FLUSHFONTCACHE NIL '* '* '* '* HTML.FONTCREATE.DEVICENAME))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (5260 5334 (DO-NOT 5260 . 5334)) (5336 5493 (\HTML-DBG 5336 . 5493)) (5495 5669 (
\HTML.TOADDR 5495 . 5669)) (6341 6530 (CLOSE-KNOTS 6341 . 6530)) (6532 6688 (HTML.INCHES-TO-POINTS 
6532 . 6688)) (6690 6792 (HTML.INCHES-TO-CENTIPOINTS 6690 . 6792)) (6794 6883 (CP-TO-P 6794 . 6883)) (
6885 7051 (ICP-TO-P 6885 . 7051)) (7053 7129 (P-TO-CP 7053 . 7129)) (7131 7290 (PIXEL-TO-PT 7131 . 
7290)) (7292 7452 (PT-TO-PIXEL 7292 . 7452)) (7454 7550 (\SF 7454 . 7550)) (7552 7700 (\HTML.SVG-Y 
7552 . 7700)) (7702 8269 (INSURE-COLOR-OR-SHADE 7702 . 8269)) (8271 8892 (MAKE-FONT-METRICS-FILE-NAME 
8271 . 8892)) (8894 9681 (MAKE-CHARSET-METRICS-FILE-NAME 8894 . 9681)) (18755 19040 (
HTML-FONT-METRICS-VERSION-OK? 18755 . 19040)) (19042 19325 (CHECK-BROWSER-METRICS-FORMAT 19042 . 19325
)) (19327 20863 (CSS-CLASS-FROM 19327 . 20863)) (20865 21003 (CSS-CLASS-FROM-FAMILY 20865 . 21003)) (
21005 22629 (\HTML.READ-FONT-METRICS 21005 . 22629)) (22631 24051 (\HTML.READ-CHARSET-METRICS 22631 . 
24051)) (24053 24975 (\HTML.SVG-STROKE-DASHARRAY 24053 . 24975)) (24977 25328 (\HTML.SVG-BRUSH-WIDTH 
24977 . 25328)) (25330 26354 (\HTML.SVG-BRUSH-CLASS 25330 . 26354)) (26356 26678 (\HTML.SVG-COLOR 
26356 . 26678)) (27984 28216 (with-htmldata 27984 . 28216)) (28218 28877 (HTML.OUTPUT-GRAPHICS 28218
 . 28877)) (28879 30083 (HTML.OUTPUT-TEXT 28879 . 30083)) (30085 31277 (\HTML.MAYBE-START-PAGE 30085
 . 31277)) (31279 31686 (\HTML.END-PAGE 31279 . 31686)) (31688 32114 (\HTML.TAB-DELTA-X 31688 . 32114)
) (32116 32919 (\HTML.CHARWIDTH 32116 . 32919)) (32921 39157 (HTML.WRITE-PREFACE 32921 . 39157)) (
39159 40137 (CONVERT-FAMILY-TO-QUERY-PARAM 39159 . 40137)) (40139 40800 (\HTML.MAKE-STYLESHEET-URL 
40139 . 40800)) (40802 46292 (OPENHTMLSTREAM 40802 . 46292)) (46294 47113 (HTML.BACKCOLOR 46294 . 
47113)) (47115 47663 (HTML.BITBLT 47115 . 47663)) (47665 49633 (HTML.BLTSHADE 47665 . 49633)) (49635 
49972 (HTML.BOTTOMMARGIN 49635 . 49972)) (49974 50760 (HTML.CHARWIDTH 49974 . 50760)) (50762 51077 (
HTML.CLIPPINGREGION 50762 . 51077)) (51079 51731 (HTML.CLOSEFN 51079 . 51731)) (51733 52496 (
HTML.COLOR 51733 . 52496)) (52498 53254 (HTML.DRAWCIRCLE 52498 . 53254)) (53256 56323 (HTML.DRAWCURVE 
53256 . 56323)) (56325 57261 (HTML.DRAWELLIPSE 56325 . 57261)) (57263 58214 (HTML.DRAWLINE 57263 . 
58214)) (58216 59213 (HTML.DRAWPOLYGON 58216 . 59213)) (59215 61410 (HTML.DRAWARC 59215 . 61410)) (
61412 61987 (HTML.FILLCIRCLE 61412 . 61987)) (61989 62880 (HTML.FILLPOLYGON 61989 . 62880)) (62882 
63933 (HTML.FONT 62882 . 63933)) (63935 64258 (HTML.LEFTMARGIN 63935 . 64258)) (64260 64651 (
HTML.LINEFEED 64260 . 64651)) (64653 65055 (HTML.MOVETO 64653 . 65055)) (65057 65173 (HTML.NEWPAGE 
65057 . 65173)) (65175 65497 (HTML.OPERATION 65175 . 65497)) (65499 71290 (HTML.OUTCHARFN 65499 . 
71290)) (71292 71636 (HTML.RESET 71292 . 71636)) (71638 71968 (HTML.RIGHTMARGIN 71638 . 71968)) (71970
 72344 (HTML.SCALE 71970 . 72344)) (72346 73759 (HTML.SCALEDBITBLT 72346 . 73759)) (73761 74067 (
HTML.SPACEFACTOR 73761 . 74067)) (74069 74710 (HTML.TERPRI 74069 . 74710)) (74712 75028 (
HTML.TOPMARGIN 74712 . 75028)) (75030 75429 (HTML.XPOSITION 75030 . 75429)) (75431 75830 (
HTML.YPOSITION 75431 . 75830)) (75832 76114 (MAKE-HTML-IMAGETYPE 75832 . 76114)) (76116 77184 (
\HTML.INIT-IMAGEDATA 76116 . 77184)) (77186 77889 (\HTMLSTREAM.INIT 77186 . 77889)) (77891 78134 (
WRITE-BASE64-PNG 77891 . 78134)) (78136 78904 (CONVERT-TO-PNG-BASE64 78136 . 78904)) (78906 80193 (
URL-ENCODE 78906 . 80193)) (80195 81412 (HTML-ENCODE 80195 . 81412)) (81696 87089 (\HTML.FONTCREATE 
81696 . 87089)) (87091 87835 (\HTML.FONTEXISTS? 87091 . 87835)) (87837 90701 (\HTML.FONTSAVAILABLE 
87837 . 90701)) (90703 94277 (HTMLFONT.GETCHARSET 90703 . 94277)) (94279 95501 (HTMLFONT.FILEP 94279
 . 95501)) (95503 98835 (\HTML.CREATECHARSET 95503 . 98835)) (98837 99675 (\HTML.CHANGECHARSET 98837
 . 99675)) (99677 100014 (MAKE-CHARSET-BIT-ARRAY 99677 . 100014)) (100016 100240 (KNOWN-CHARSET? 
100016 . 100240)) (100242 100776 (\HTML.WARN-CHARSET 100242 . 100776)) (100778 102160 (
\HTML.ADD-FONT-DEFS 100778 . 102160)) (102162 102584 (\FIRST-COERCION 102162 . 102584)) (102586 103342
 (\HTML.COERCE-OR-IDENTITY 102586 . 103342)) (103344 104262 (\HTML.COERCE-FONT 103344 . 104262)) (
104264 104631 (MAYBE-MARK-FONT-COMPLETE 104264 . 104631)) (104666 104958 (\HTML.FONTCREATE-NEW 104666
 . 104958)) (105229 106133 (HTML.CREATE-MEDLEYFONT-FAMILY 105229 . 106133)) (106135 106356 (
HTML.CREATE-ALL-MEDLEYFONT-FAMILIES 106135 . 106356)) (106772 107947 (HTMLFILEP 106772 . 107947)) (
107949 108091 (MAKE-HTML-FROM-TEXT 107949 . 108091)) (108093 108502 (MAKE-HTML-FROM-TEDIT 108093 . 
108502)) (108795 108936 (\CLEAN-FONT-CACHE 108795 . 108936)))))
STOP