Skip to content

Instantly share code, notes, and snippets.

@greggirwin

greggirwin/get-fonts-windows.r

Created June 23, 2018 21:23
Show Gist options
  • Save greggirwin/866758a6763871df6206ac360d06c804 to your computer and use it in GitHub Desktop.
Save greggirwin/866758a6763871df6206ac360d06c804 to your computer and use it in GitHub Desktop.
Download ZIP
Rebol2/R2 font requestor
Raw
get-fonts-windows.r
;do/args %./fonts/fonts-startup.r %get-fonts-windows.r
;request-font
REBOL [
Title: "get-fonts-windows"
Date: 29-Sep-2002
Name: 'get-fonts-windows
Version: 0.1.0
File: %get-fonts-windows.r
Author: "Gregg Irwin"
Email: [email protected]
Rights: "Public Domain"
Tabs: 4
Needs: [view 1.2.1]
Language: 'English
Charset: 'ANSI
Purpose: {
To grab the names of the fonts available on Windows and return
them as objects in a block for use by the get-fonts and
request-font functions created by the fonts-startup.r script.
}
Note: {
1) This script should be placed in the same directory as the
fonts-startup.r and request-font.r scripts.
2) The script is run from the get-fonts function - there's
no need to run it seperately, though you can do so to test it.
3) * How to write versions of the get-fonts script for other OSs *
All that's required of the script is that it extracts the font
names from those available on the OS and returns them in
seperate objects within a block. The objects should be made
as follows...
make object! [
name: "font name"
]
where "font name" is a string containing a font's name.
How you write the script is up to you, but it should not add
any words to the global context. One way to do this is to
hide the code in a function. For example...
do make function! [/local word1 word2 word3][
...
code using word1, word2 and word3
...
]
Note that the objects do not have to be sorted or checked
for duplicates as this is done by the get-fonts function
that runs the script.
The file-name of the script should reflect the OS it is
written for. ie, get-fonts-[OS-type].r.
ERRORS: If the get-fonts function receives a string back
instead of a block it assumes there's been an error and
the string contains an error-message. So if your script
can capture errors, return a string containing a description
of the error.
}
History: [
0.0.1 [29-Sep-2002 {
First version. Based on ttf-parser.r but built to match
Carl Read's new design.}
]
0.1.0 [03-Dec-2002 "First release. Forgot about it for 6 weeks. :)"]
]
]
; Enclose code in function to prevent
; words being added to global context
;-------------------------------------
; IMPORTANT NOTE! This only returns TrueType font names. I.e. font names
; for any TTF files it finds in the specified directory.
do make function! [/local ttf-parser file names][
; file-path to save block of fonts data to
;------------------------------------------
file: join what-dir %fonts-data.txt
; Patch suffix? in for < 1.2.5
if not value? 'suffix? [
suffix?: func [
{Return the suffix (ext) of a filename or url, else NONE.}
path [any-string!]
][
if all [
path: find/last path #"."
not find path #"/"
] [to-file path]
]
]
ttf-parser: make object! [
; This sets where it will look for fonts. Just a simple dir
; spec is supported right now.
;font-dir: %//windows/fonts/
font-dir: %/c/windows/fonts/
null-buff: func [
{Returns a null-filled string buffer of the specified length.}
len [integer!]
][
head insert/dup make string! len #"^@" len
]
buff-to-num: func [buf /big-endian] [
either big-endian [
to integer! to binary! buf
][
to integer! to binary! head reverse buf
]
]
;The following data types are used in the TrueType font file.
;All TrueType fonts use Motorola-style byte ordering (Big Endian):
;BYTE: ;8-bit unsigned integer.
;CHAR: ;8-bit signed integer.
;USHORT: ;16-bit unsigned integer.
;SHORT: ;16-bit signed integer.
;ULONG: ;32-bit unsigned integer.
;LONG: ;32-bit signed integer.
;FIXED: ;32-bit signed fixed-point number (16.16)
;FUNIT Smallest measurable distance in the em space.
;FWORD 16-bit signed integer (SHORT) that describes a quantity in FUnits.
;UFWORD Unsigned 16-bit integer (USHORT) that describes a quantity in FUnits.
;F2DOT14 16-bit signed fixed number with the low 14 bits of fraction (2.14).
;The TrueType font file begins at byte 0 with the Offset Table.
table-directory: make object! [
version: ;Fixed 0x00010000 for version 1.0.
num-tables: ;USHORT Number of tables.
search-range: ;USHORT (Maximum power of 2 <= numTables) x 16.
entry-selector: ;USHORT Log2(maximum power of 2 <= numTables).
range-shift: ;USHORT NumTables x 16 - searchRange.
none
]
;This is followed at byte 12 by the Table Directory entries.
; Entries in the Table Directory must be sorted in ascending order by tag.
table-directory-entry: make object! [
tag: ;ULONG 4-byte identifier.
checkSum: ;ULONG CheckSum for this table.
offset: ;ULONG Offset from beginning of TrueType font file.
length: ;ULONG Length of this table.
none
]
;The Table Directory makes it possible for a given font to contain only
;those tables it actually needs. As a result there is no standard value
;for numTables.
comment {
Tags are the names given to tables in the TrueType font file. At present,
all tag names consist of four characters, though this need not be the case.
Names with less than four letters are allowed if followed by the necessary
trailing spaces. A list of the currently defined tags follows.
}
;Required Tables
;Tag Name
; required-tables: [
; cmap "character to glyph mapping"
; glyf "glyph data"
; head "font header"
; hhea "horizontal header"
; hmtx "horizontal metrics"
; loca "index to location"
; maxp "maximum profile"
; name "naming table"
; post "PostScript information"
; OS/2 "OS/2 and Windows specific metrics"
; ]
;Optional Tables
;Tag Name
; optional-tables: [
; cvt "Control Value Table"
; EBDT "Embedded bitmap data"
; EBLC "Embedded bitmap location data"
; EBSC "Embedded bitmap scaling data"
; fpgm "font program"
; gasp "grid-fitting and scan conversion procedure (grayscale)"
; hdmx "horizontal device metrics"
; kern "kerning"
; LTSH "Linear threshold table"
; prep "CVT Program"
; PCLT "PCL5"
; VDMX "Vertical Device Metrics table"
; vhea "Vertical Metrics header"
; vmtx "Vertical Metrics"
; ]
comment {
Other tables may be defined for other platforms and for future expansion.
Note that these tables will not have any effect on the scan converter.
Tags for these tables must be registered with Apple Developer Technical
Support. Tag names consisting of all lower case letters are reserved for
Apple's use. The number 0 is never a valid tag name.
}
; name table
name-table: make object! [
format: ;USHORT Format selector (=0).
num-records: ;USHORT Number of NameRecords that follow n.
offset: ;USHORT Offset to start of string storage (from start of table).
none
records: copy [] ;The NameRecords.
string-data: none ;(Variable) Storage for the actual string data.
]
name-record: make object! [
platform: ;USHORT Platform ID.
encoding-id: ;USHORT Platform-specific encoding ID.
language-id: ;USHORT Language ID.
name-id: ;USHORT Name ID.
string-length: ;USHORT String length (in bytes).
string-offset: ;USHORT String offset from start of storage area (in bytes).
none
]
; platform-ids: [
; 0 Apple-Unicode ""
; 1 Macintosh "Script manager code"
; 2 ISO "ISO encoding"
; 3 Microsoft "Microsoft encoding"
; ]
;
; ; ?encoding ids are only used with Microsoft platform?
; encoding-ids: [
; 0 "Undefined character set or indexing scheme"
; 1 "UGL character set with Unicode indexing scheme"
; ]
;
; language-ids: [
; ; lots of stuff here. Not sure I want to tackle it right now.
; ]
;
; name-ids: [
; 0 ;Copyright notice.
; 1 ;Font Family name
; 2 ;Font Subfamily name; for purposes of definition, this is assumed to address style (italic, oblique) and weight (light, bold, black, etc.) only. A font with no particular differences in weight or style (e.g. medium weight, not italic and fsSelection bit 6 set) should have the string "Regular" stored in this position.
; 3 ;Unique font identifier
; 4 ;Full font name; this should simply be a combination of strings 1 and 2. Exception: if string 2 is "Regular," then use only string 1. This is the font name that Windows will expose to users.
; 5 ;Version string. In n.nn format.
; 6 ;Postscript name for the font.
; 7 ;Trademark; this is used to save any trademark notice/information for this font. Such information should be based on legal advice. This is distinctly separate from the copyright.
; ]
integer-to-version: func [value [integer!]][
add
to integer! divide value 65536
divide (value and 65535) 10
]
get-ttf-num: func [data offset length] [
buff-to-num/big-endian copy/part at data offset length
]
get-fonts: func [
/local font-dir files font-names tables data td tbl-pos
name-table-data name-tbl
][
font-names: copy []
files: copy []
;print mold clean-path ttf-parser/font-dir
foreach file read ttf-parser/font-dir [
if %.ttf = suffix? file [
append files file
]
]
foreach file files [
tables: copy []
data: read/binary join ttf-parser/font-dir file
; Main table directory
td: make table-directory []
td/version: get-ttf-num data 0 4
td/num-tables: get-ttf-num data 5 2
td/search-range: get-ttf-num data 7 2
td/entry-selector: get-ttf-num data 9 2
td/range-shift: get-ttf-num data 11 2
; print [
; "version=" integer-to-version td/version
; "num-tables=" td/num-tables
; "search-range=" td/search-range
; "entry-selector=" td/entry-selector
; "range-shift=" td/range-shift
; ]
; table directory entries for each table
repeat i td/num-tables [
tbl-pos: i - 1 * 16 + 13 ; 16 = struct length, 13 = offset from BOF
entry: make table-directory-entry [
tag: to-word to-string copy/part at data tbl-pos + 0 4
checksum: get-ttf-num data tbl-pos + 4 4
offset: get-ttf-num data tbl-pos + 8 4
length: get-ttf-num data tbl-pos + 12 4
]
append tables entry
]
;foreach table tables [print [table/offset table/length table/tag]]
; Do a brute force search for the name table
name-table-data: none
foreach table tables [
if table/tag = 'name [
name-table-data: copy/part at data table/offset + 1 table/length
break
]
]
if name-table-data [
;print length? name-table-data
name-tbl: make name-table [
format: get-ttf-num name-table-data 0 2
num-records: get-ttf-num name-table-data 3 2
offset: get-ttf-num name-table-data 5 2
string-data: to-string copy at name-table-data offset
]
;probe name-tbl
repeat i name-tbl/num-records [
tbl-pos: i - 1 * 24 + 7 ; 24 = struct length, 7 = offset from table start
entry: make name-record [
platform: get-ttf-num name-table-data tbl-pos + 0 2
encoding-id: get-ttf-num name-table-data tbl-pos + 2 2
language-id: get-ttf-num name-table-data tbl-pos + 4 2
name-id: get-ttf-num name-table-data tbl-pos + 6 2
string-length: get-ttf-num name-table-data tbl-pos + 8 2
string-offset: get-ttf-num name-table-data tbl-pos + 10 2
; This is my extension for testing
string-data: to-string copy/part at name-table-data 1 + name-tbl/offset + string-offset string-length
]
append name-tbl/records entry
; Use English string for testing here
; name-id 4 = full font name
; language-id 0 = english
if all [entry/name-id = 4 entry/language-id = 0] [
if find entry/string-data #"^@" [
entry/string-data: replace/all entry/string-data #"^@" ""
]
append font-names make object! [name: entry/string-data]
;print mold entry/string-data
]
]
]
]
head font-names
]
]
names: ttf-parser/get-fonts
; Save block of fonts-data objects
;----------------------------------
if error? try [save file head names][
print "Error attempting to save block of fonts data"
print ["to:" file]
halt
]
]
Raw
request-font.r
REBOL [
Title: "request-font"
Date: 21-Dec-2002
Name: 'request-font
Version: 0.1.2
File: %request-font.r
Home: http://to-be-added-when-no-longer-homeless/
Author: "Carl Read"
Email: [email protected]
Rights: "Public Domain"
Tabs: 4
Needs: [REBOL/View 1.2.1]
Language: 'English
Charset: 'ANSI
Purpose: {
A font-requester for REBOL/View.
}
Note: {
1) This script should be placed in the same directory as the
get-fonts-[OS-type].r script. Ideally, it should be run when
REBOL/View is first launched, such as from the user.r script.
2) For this script to work, it needs to find a file called
fonts-data.txt in the directory it is run from. fonts-data.txt
is created by running the get-fonts-[OS-type].r script. (See
that script's Notes for how and when to run it.)
3) When run, this script creates a block of objects containing
font data and a function called request-font which provides a
font-requester for View. Those who wish to modify or write a
new request-font function should ensure the "Load Fonts Data"
code at the start of the script is included in their script.
(That's assuming they're wishing to replace the request-font.r
script with their own. An alternative request-font function
created after this script has been run wouldn't need to do
this.)
5) A description of the request-font refinements for those
wanting to write a better requester...
/title title-line
Change the default title. The default is "Select a Font:".
/name font-name
Changes the default font name. Can be a string or block of
strings. The default is the font-sans-serif string. If a
block of strings are supplied they'll all be shown as picked
in the text-list and the multi refinement will be set to true.
/style font-style
This both gives the user the option of editing the font style
as well as allowing the script to set the style. The style
can be none, 'bold, italic or 'underline, or, if a block is
supplied, any mix of [bold italic underline]. none is the
default style.
/size font-size
Changes the default font size. The default is 12. If none
is supplied then the option for the user to edit the size
isn't provided on the requester.
/color font-color
This both gives the user the option of editing the font color
as well as allowing the script to set the color. The default
color is black - 0.0.0.
/font font-obj
Allows the script to supply a font object. The font object
supplied doesn't need to include all the font settings. This
for instance...
make object! [size: 24 style: [bold italic]]
will just change the size and style of the default font
object. This offers a way to set the settings without giving
the user a means to edit them, as the individual refinements
do.
/effects
A REBOL font-object can have the following extra settings:
offset, space, align, valign, shadow and colors. The effects
refinement adds options to the requester to edit all of
these.
/keep
This keeps the settings and results from the previous use of
requester. Note that the other refinements will override this,
allowing you for instance to keep all the previous setting
except for size if that's the behaviour you want.
/multi
Allow more than one font-name to be selected. This will
result in a block of names being returned in the font object
instead of a string.
}
History: [
0.0.0 [28-Sep-2002 "First alpha version."]
0.0.1 [6-Oct-2002 "Half-finished alpha version."]
0.0.2 [12-Oct-2002 "Finished alpha version."]
0.1.0 [19-Oct-2002 "First beta version."]
0.1.1 [11-Dec-2002 {Fixed "focus-on-font" bug.}]
0.1.2 [12-Dec-2002 {Fixed "return-to-default-font" bug.}]
]
]
; Load Fonts Data
;=================
if not value? 'fonts [fonts: []]
if error? try [
insert clear fonts reduce load %fonts-data.txt
][
print "Error loading fonts data while running %request-font.r."
halt
]
; Ensure default fonts are included
;-----------------------------------
append fonts reduce [
make object! [name: font-fixed]
make object! [name: font-sans-serif]
make object! [name: font-serif]
]
; Sort and remove duplicates
;----------------------------
sort/compare fonts func [a b][a/name < b/name]
forall fonts [
while [all [fonts/1 <> last fonts fonts/1/name = fonts/2/name]][
remove fonts
]
]
fonts: head fonts
; End of Load fonts Data
;========================
; Create request-font Function
;==============================
request-font: func [
{Requests a font-name and optional settings. Returns a font-object. If
more than one font is selected the objects name will contain a block of
names. With /style, /size and /color, 'keep may be given to keep the
previous settings. This allows you to place the style, size and color
fields in the requester without forcing them to have a specific value.}
/title "Change heading on request."
title-line [string!] "Title line of request."
/name font-name [string! block!] "Font name. Default is font-sans-serif."
/style font-style [word! block! none!]
/size font-size [integer! none!]
/color font-color [tuple! word!]
/font font-obj [object!] "Supply a font object."
/text string [string!] "Supply example text."
/effects {Allow editing of offset, space, align, valign, shadow and
colors.}
/keep "Keep previous settings and results."
/multi "Allow more than one font name to be selected."
/local settings fon refs set-style show-font get-color names icon-image
lo req-list fn str blk rgb bold italic underline pos s1 s2 hi result
find-font
][
; A block to keep settings in between function calls
;----------------------------------------------------
settings: []
; Initialize font and refinement objects or
; get them from settings if keep was set.
either any [empty? settings not keep][
fon: make object! [
name: copy font-sans-serif
style: none
size: 12
color: 0.0.0
offset: 2x2
space: 0x0
align: 'left
valign: 'top
shadow: none
colors: [0.0.0 255.180.55]
]
refs: make object! [
title: copy "Select a Font:"
str: copy "The quick brown fox jumped over the lazy dogs."
name: style: size: color: effects: multi: false
font-size: 12
]
][
fon: make settings/1 []
refs: make settings/2 []
]
; Change fon and refs values based on refinements
;-------------------------------------------------
if font-obj [fon: make fon font-obj]
either any [block? font-name multi][
multi: refs/multi: true
if string? font-name [font-name: reduce [font-name]]
if string? fon/name [fon/name: reduce [fon/name]]
][
multi: refs/multi
]
either name [fon/name: font-name refs/name: true][name: refs/name]
either style [fon/style: font-style refs/style: true][style: refs/style]
either size [
if font-size [fon/size: font-size]
refs/size: true
refs/font-size: font-size
][
size: refs/size font-size: refs/font-size
]
either color [
fon/colors/1: fon/color: font-color refs/color: true
][
color: refs/color
]
if title [refs/title: title-line]
either effects [refs/effects: true][effects: refs/effects]
either string [refs/str: string][string: refs/str]
; Some functions
;----------------
set-style: does [
clear str/font/style
if bold/state [append str/font/style 'bold]
if italic/state [append str/font/style 'italic]
if underline/state [append str/font/style 'underline]
show str
]
show-font: func [blk][
insert clear req-list/picked intersect blk names
if not multi [remove/part req-list/picked -1 + length? req-list/picked]
insert clear fn/text form req-list/picked
str/font/name: last join reduce [font-sans-serif] req-list/picked
show [req-list fn str]
]
get-color: func [str /local color][
color: to-block trim str
if error? try [
color: to-tuple either word? last :color [
first reduce head change [none] to-get-word last :color
][
last :color
]
][
color: none
]
color
]
; Setup names list for text-list
;--------------------------------
names: clear []
foreach font fonts [append names font/name]
; Build layout
;--------------
icon-image: to-image layout [
backdrop black origin 1x1 space 1x1 across
box 4x16 effect [gradient 0x1 255.0.0 0.0.0]
box 4x16 effect [gradient 0x1 0.255.0 0.0.0]
box 4x16 effect [gradient 0x1 0.0.255 0.0.0]
]
if none? fon/shadow [fon/shadow: 0x0]
lo: copy [
origin 10x10
style req-color button 24 effect [
gradient 0x1 66.120.192 44.80.132
draw [image icon-image 2x2]
]
style lab1 h4 60 right white shadow 1x1
style lab2 lab1 50
vh2 refs/title
across
space 2x4
lab1 "Fonts:"
req-list: text-list data names (
either system/view/screen-face/size/y < 600 [410x80][410x200]
) [
unfocus
show-font copy/deep req-list/picked
]
return
lab1 "Font:"
fn: field 410 [
either find names trim fn/text [
show-font parse/all fn/text " "
][
if not empty? fn/text [
unfocus
request/ok rejoin[{Font: "} fn/text {"could not be found.}]
]
fn/text: copy str/font/name
show fn
]
]
return
lab1 "Text:"
str: field 410x60 refs/str font [style: copy []] feel [
over: func [face action event][
if all [effects face/font face/font/colors] [
face/font/color: pick face/font/colors not action
show face
face/font/color: first face/font/colors
]
]
][refs/str: str/text]
return
]
blk: copy []
if not all [size not font-size][append blk [
lab2 "Size:" field 40 form fon/size [
error? try [str/font/size: to-integer face/text]
face/text: form refs/font-size: str/font/size
show [face str]
]
]]
if any [color effects][append blk [
lab2 "Color:" rgb: field 80 form fon/color [
if rgb/text: get-color rgb/text [
str/font/colors/1: str/font/color: rgb/text
]
rgb/text: form str/font/color
show [rgb str]
]
req-color [
if rgb/text: request-color/color str/font/color [
str/font/colors/1: str/font/color: rgb/text
]
rgb/text: form str/font/color
show [rgb str]
]
]]
if style [append blk [
lab2 "Style:"
bold: toggle "B" 24 font [style: 'bold][set-style]
italic: toggle "I" 24 font [style: 'italic][set-style]
underline: toggle "U" 24 font [style: 'underline][set-style]
]]
if not empty? blk [
append lo [
lab1 "Options:"
pos: at
box 410x38 edge [
size: 2x2 color: 110.120.130 effect: 'bevel
]
at pos + 8x8
]
append lo blk append lo 'return
]
if effects [append lo [
lab1 "Effects:"
pos: at
box 410x68 edge [
size: 2x2 color: 110.120.130 effect: 'bevel
]
at pos + 8x8
lab2 "Offset:"
field form fon/offset 40 [
error? try [face/text: to-pair face/text]
if face/text [str/font/offset: face/text]
face/text: form str/font/offset
show [face str]
]
lab2 "Align:"
s1: rotary "Left" "Center" "Right" 80 [
str/font/align: to-word face/text
show str
]
lab1 "VAlign:"
s2: rotary "Top" "Middle" "bottom" 80 [
str/font/valign: to-word face/text
show str
]
at pos + 8x36
lab2 "Space:"
field form fon/space 40 [
error? try [face/text: to-pair face/text]
if face/text [str/font/space: face/text]
face/text: form str/font/space
show [face str]
]
lab1 "Shadow:"
field form fon/shadow 40 [
error? try [face/text: to-pair face/text]
if face/text [str/font/shadow: face/text]
face/text: form str/font/shadow
show [face str]
]
lab1 "Hilight:"
hi: field form fon/colors/2 80 [
if hi/text: get-color hi/text [
str/font/colors/2: hi/text
]
hi/text: form str/font/colors/2
show [hi str]
]
req-color [
if hi/text: request-color/color str/font/colors/2 [
str/font/colors/2: hi/text
]
hi/text: form str/font/colors/2
show [hi str]
]
return
]]
append lo [
button "Select" [
unview/only lo
result: str/font
if result/shadow = 0x0 [result/shadow: none]
if 1 = length? result/style [result/style: result/style/1]
if all [block? result/style empty? result/style][
result/style: none
]
if multi [result/name: copy/deep req-list/picked]
insert clear settings reduce [result refs]
]
pad 270 button "Cancel" [unview/only lo result: none]
]
lo: layout lo
str/font: make fon [style: copy []]
if fon/style [append str/font/style fon/style]
if style [
if find str/font/style 'bold [bold/state: true]
if find str/font/style 'italic [italic/state: true]
if find str/font/style 'underline [underline/state: true]
]
str/para: make str/para []
either effects [
str/para/wrap?: true
s1/data: find s1/data form fon/align
s2/data: find s2/data form fon/valign
][
str/font/valign: 'middle
]
append req-list/picked fon/name
show-font copy/deep req-list/picked
; Open requester
;----------------
view/title center-face lo "Request Font"
result
]
; End of Create request-font Function
;=====================================
Raw
test-req-font.r
REBOL []
do %get-fonts-windows.r
do %request-font.r
request-font
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment