FontSampler sample sheet display in column major order.

lispusers/FONTSAMPLER

@@ -1,12 +1,12 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
 
-
(FILECREATED " 5-Feb-2025 17:03:38" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;11
 9743   
+
(FILECREATED " 5-Dec-2025 11:09:30" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;6
 12333  
 
       :EDIT-BY "mth"
 
       :CHANGES-TO (FNS FontSample FontTable)
 
-      :PREVIOUS-DATE " 3-Feb-2025 20:08:40" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;10
+      :PREVIOUS-DATE " 4-Dec-2025 23:56:07" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;5
 )
 
 
@@ -21,30 +21,62 @@
 
 (FontSample

   [LAMBDA (Fonts CharacterSets Printer StreamType Hexadecimal)

+                                                             (* ; "Edited  5-Dec-2025 11:06 by mth")


                                                              (* ; "Edited  5-Feb-2025 17:02 by mth")

-                                                             (* edited%: "29-Apr-87 22:03")

-    (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer]
+                                                             (* ; "Edited 29-Apr-87 22:03")

+    (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (SETQ StreamType (OR StreamType (PRINTERTYPE Printer]
            (FontList (if
 (LISTP Fonts)
                        else
 (CONS Fonts)))
            [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (CONS TitleFont FontList]
            (InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream)))
            (LastFont (CAR (LAST FontList)))
            [CharacterSets (if
 (LISTP CharacterSets)
                               then
 CharacterSets
+                            elseif
 (MEMB CharacterSets '(T :INCORE :ALL :INTERESTING))
+                              then
 CharacterSets
                             else
 (LIST (OR CharacterSets 0]
-           (LastCharacterSet (CAR (LAST CharacterSets]
+           (AllCharacterSets (CONSTANT (for
 CS from
 0 to
 255 collect
 CS]
           (DSPRIGHTMARGIN (fetch
 (REGION WIDTH) of
 (DSPCLIPPINGREGION NIL Stream))
                  Stream)
-          (for
 Font in
 FontList do
 (for
 CharacterSet in
 CharacterSets
-                                      do
 (FontTable
 Font CharacterSet Stream (OR (NEQ Font LastFont)
-                                                                                 (NEQ CharacterSet 
-                                                                                     LastCharacterSet
-                                                                                      ))
-                                                TitleFont InchesToPrinterUnits Hexadecimal))
+          (for
 Font in
 FontList do
 
+                                   (* ;; "Check for the special charset list builders")

+
+                                   (LET (FontCharacterSets (SlugCharsetInfo (\GETCHARSETINFO Font 
+                                                                                   SLUGCHARSET)))
+                                        (SETQ FontCharacterSets
+                                         (SELECTQ CharacterSets
+                                             (:ALL 
+                                                   (* ;; "Forcibly install ALL CharacterSets.")

+
+                                                   (for
 CS in
 AllCharacterSets
+                                                      when
 (\INSURECHARSETINFO Font CS) collect

+                                                                                        CS))
+                                             (:INTERESTING (for
 CS in
 *INTERESTING-CHARSETS*
+                                                              when
 (\INSURECHARSETINFO Font CS)
+                                                              collect
 CS))
+                                             ((T :INCORE) 
+                                                  (for
 CS in
 AllCharacterSets
+                                                     when
 (\GETCHARSETINFO Font CS) collect
 CS))
+                                             CharacterSets))
+
+                                        (* ;; 
+
                                    "Exclude any CharacterSet known to reference the SlugCharsetInfo")

+
+                                        (SETQ FontCharacterSets (for
 CS in
 FontCharacterSets
+                                                                   unless
 (EQ SlugCharsetInfo
+                                                                              (\GETCHARSETINFO Font 
+                                                                                     CS))
+                                                                   collect
 CS))
+                                        (for
 CharacterSet in
 FontCharacterSets
+                                           bind
 (LastCharacterSet _ (CAR (LAST FontCharacterSets)))
+                                           do
 (FontTable
 Font CharacterSet Stream
+                                                     (OR (NEQ Font LastFont)
+                                                         (NEQ CharacterSet LastCharacterSet))
+                                                     TitleFont InchesToPrinterUnits Hexadecimal)))
              finally
 (CLOSEF Stream])
 
 (FontSampleFaked

-  [LAMBDA (FontAsList Printer StreamType)
                    (* N.H.Briggs "27-Apr-87 18:12")

+  [LAMBDA (FontAsList Printer StreamType)                    (* N.H.Briggs "27-Apr-87 18:12")

     (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer]
            (Font)
            [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (LIST TitleFont]
@@ -53,14 +85,16 @@
           (replace
 FONTFAMILY of
 Font with
 (CAR FontAsList))
           (replace
 FONTSIZE of
 Font with
 (CADR FontAsList))
           (replace
 FONTFACE of
 Font with
 (\FONTFACE (CADDR FontAsList)))
-          (FontTable
 Font '(0) Stream NIL TitleFont InchesToPrinterUnits)
+          (FontTable
 Font '(0)
+                 Stream NIL TitleFont InchesToPrinterUnits)
           (CLOSEF Stream])
 
 (FontTable

   [LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits Hexadecimal)

+                                                             (* ; "Edited  5-Dec-2025 11:09 by mth")


                                                              (* ; "Edited  5-Feb-2025 17:03 by mth")


                                                              (* ; "Edited  3-Feb-2025 20:07 by mth")

-                                                             (* edited%: "29-Apr-87 22:36")

+                                                             (* ; "Edited 29-Apr-87 22:36")

     (LET*
      ((Family (FONTPROP Font 'FAMILY))
       (Face (FONTPROP Font 'FACE))
@@ -119,10 +153,12 @@
             (DSPSCALE NIL Stream)
             'PAINT Stream)
      (CL:UNLESS UseDisplayFontBitmaps (DSPFONT Font Stream))
-     (for
 YPosition from
 (TIMES 9 InchesToPrinterUnits) by
 (MINUS YCellSpacing) as
 YCounter
-        from
 0 to
 15 bind
 (CharacterCode _ 0)
+     (for
 XPosition from
 (TIMES 0.75 InchesToPrinterUnits) by
 XCellSpacing as
 XCounter from
 0
+        to
 15 bind
 (CharacterCode _ 0)
+                   [RangedCodesStreamType _ (MEMB (IMAGESTREAMTYPE Stream)
+                                                  '(DISPLAY INTERPRESS]
         do

-        (for
 XPosition from
 (TIMES 0.75 InchesToPrinterUnits) by
 XCellSpacing as
 XCounter
+        (for
 YPosition from
 (TIMES 9 InchesToPrinterUnits) by
 (MINUS YCellSpacing) as
 YCounter
            from
 0 to
 15
            do
 [LET ((CCode (IPLUS (ITIMES CharacterSet 256)
                                   CharacterCode)))
@@ -137,8 +173,7 @@
                                                                                    RelativeDescent))
                                          ImWidth ImHeight 'INPUT 'REPLACE))
                      else
 (if
 (AND (NEQ CharacterCode (CHARCODE FF))
-                                   (if
 (MEMB (IMAGESTREAMTYPE Stream)
-                                             '(DISPLAY INTERPRESS))
+                                   (if
 RangedCodesStreamType
                                        then
 (OR (AND (IGREATERP CharacterCode 31)
                                                      (ILESSP CharacterCode 127))
                                                 (AND (IGREATERP CharacterCode 160)
@@ -185,6 +220,6 @@
        FONT)
 )
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (657 9580 (FontSample 667 . 2302) (FontSampleFaked 2304 . 3113) (FontTable 3115 . 9578))
-)))
+  (FILEMAP (NIL (655 12170 (FontSample 665 . 4700) (FontSampleFaked 4702 . 5524) (FontTable 5526 . 12168
+)))))
 STOP