PIKApp/plug-ins/script-fu/scripts/font-map.scm

178 lines
5.8 KiB
Scheme

;; font-map
;; Spencer Kimball
;; To test, open the Font tool dialog,
;; press right mouse button in the list of fonts, choose "Render Font Map"
;; Test cases for font filter regex
;; ".*" expect render all installed fonts
;; "foo" expect render blank image (no matching fonts)
;; "Sans" expect render subset of installed fonts
(define (script-fu-font-map text
use-name
labels
font-filter
font-size
border
colors)
(define (max-font-width text use-name list-cnt list font-size)
(let* ((count 0)
(width 0)
(maxwidth 0)
(font "")
(extents '()))
(while (< count list-cnt)
(set! font (car list))
(if (= use-name TRUE)
(set! text font))
(set! extents (pika-text-get-extents-fontname text
font-size PIXELS
font))
(set! width (car extents))
(if (> width maxwidth)
(set! maxwidth width))
(set! list (cdr list))
(set! count (+ count 1))
)
maxwidth
)
)
(define (max-font-height text use-name list-cnt list font-size)
(let* ((count 0)
(height 0)
(maxheight 0)
(font "")
(extents '()))
(while (< count list-cnt)
(set! font (car list))
(if (= use-name TRUE)
(set! text font)
)
(set! extents (pika-text-get-extents-fontname text
font-size PIXELS
font))
(set! height (cadr extents))
(if (> height maxheight)
(set! maxheight height)
)
(set! list (cdr list))
(set! count (+ count 1))
)
maxheight
)
)
(let* (
; pika-fonts-get-list returns a one element list of results,
; the only element is itself a list of fonts, possibly empty.
(font-list (car (pika-fonts-get-list font-filter)))
(num-fonts (length font-list))
(label-size (/ font-size 2))
(border (+ border (* labels (/ label-size 2))))
(y border)
(maxheight (max-font-height text use-name num-fonts font-list font-size))
(maxwidth (max-font-width text use-name num-fonts font-list font-size))
(width (+ maxwidth (* 2 border)))
(height (+ (+ (* maxheight num-fonts) (* 2 border))
(* labels (* label-size num-fonts))))
(img (car (pika-image-new width height (if (= colors 0)
GRAY RGB))))
(drawable (car (pika-layer-new img width height (if (= colors 0)
GRAY-IMAGE RGB-IMAGE)
"Background" 100 LAYER-MODE-NORMAL)))
(count 0)
(font "")
)
(pika-context-push)
(pika-image-undo-disable img)
(if (= colors 0)
(begin
(pika-context-set-background '(255 255 255))
(pika-context-set-foreground '(0 0 0))))
(pika-image-insert-layer img drawable 0 0)
(pika-drawable-edit-clear drawable)
(if (= labels TRUE)
(begin
(set! drawable (car (pika-layer-new img width height
(if (= colors 0)
GRAYA-IMAGE RGBA-IMAGE)
"Labels" 100 LAYER-MODE-NORMAL)))
(pika-image-insert-layer img drawable 0 -1)))
(pika-drawable-edit-clear drawable)
(while (< count num-fonts)
(set! font (car font-list))
(if (= use-name TRUE)
(set! text font))
(pika-text-fontname img -1
border
y
text
0 TRUE font-size PIXELS
font)
(set! y (+ y maxheight))
(if (= labels TRUE)
(begin
(pika-floating-sel-anchor (car (pika-text-fontname img drawable
(- border
(/ label-size 2))
(- y
(/ label-size 2))
font
0 TRUE
label-size PIXELS
"Sans")))
(set! y (+ y label-size))
)
)
(set! font-list (cdr font-list))
(set! count (+ count 1))
)
(pika-image-set-selected-layers img 1 (vector drawable))
(pika-image-undo-enable img)
(pika-display-new img)
(pika-context-pop)
)
)
(script-fu-register "script-fu-font-map"
_"Render _Font Map..."
_"Create an image filled with previews of fonts matching a fontname filter"
"Spencer Kimball"
"Spencer Kimball"
"1997"
""
SF-STRING _"_Text" "How quickly daft jumping zebras vex."
SF-TOGGLE _"Use font _name as text" FALSE
SF-TOGGLE _"_Labels" TRUE
SF-STRING _"_Filter (regexp)" "Sans"
SF-ADJUSTMENT _"Font _size (pixels)" '(32 2 1000 1 10 0 1)
SF-ADJUSTMENT _"_Border (pixels)" '(10 0 200 1 10 0 1)
SF-OPTION _"_Color scheme" '(_"Black on white" _"Active colors")
)
(script-fu-menu-register "script-fu-font-map"
"<Fonts>")