examples/demo.sgl — sigil-harfbuzz

1;;; HarfBuzz text shaping demo

2;;;

3;;; Shapes text with HarfBuzz and renders it on a Cairo surface using

4;;; glyph-level positioning. Demonstrates the full FreeType + HarfBuzz +

5;;; Cairo integration pipeline.

6;;;

7;;; Usage: sigil eval -f packages/sigil-harfbuzz/examples/demo.sgl

8;;;

9;;; Requires: libfreetype, libharfbuzz, libcairo, and a system font

10;;; (uses fontconfig to locate one automatically).

12(import (sigil core)

13 (sigil io)

14 (sigil process)

15 (sigil ffi)

16 (freetype)

17 (harfbuzz)

18 (cairo))

20;; ============================================================

21;; Font discovery

22;; ============================================================

24(define (find-font name)

25 (guard (exn (#t #f))

26 (call-with-process "fc-match" (list "--format=%{file}" name)

27 (lambda (p)

28 (let ((line (read-line (process-stdout p))))

29 (if (eof-object? line) #f line))))))

31;; ============================================================

32;; Text rendering helper

33;; ============================================================

35;; Shape a string and render it at (x, y) on a Cairo context.

36;; Returns the x position after the last glyph (for chaining).

37(define (draw-shaped-text cr hb-font text x y)

38 (let ((buf (hb-buffer-create)))

39 (hb-buffer-add-utf8 buf text)

40 (hb-buffer-guess-segment-properties buf)

41 (hb-shape hb-font buf)

42 (let ((infos (hb-buffer-get-glyph-infos buf))

43 (positions (hb-buffer-get-glyph-positions buf)))

44 ;; Build the glyph list with accumulated positions

45 (let loop ((is infos) (ps positions) (cx x) (glyphs '()))

46 (if (null? is)

47 (begin

48 (cairo-show-glyphs cr (reverse glyphs))

49 (hb-buffer-destroy buf)

50 cx)

51 (let* ((info (car is))

52 (pos (car ps))

53 (gx (+ cx (/ (dict-ref pos x-offset:) 64.0)))

54 (gy (- y (/ (dict-ref pos y-offset:) 64.0))))

55 (loop (cdr is) (cdr ps)

56 (+ cx (/ (dict-ref pos x-advance:) 64.0))

57 (cons (dict index: (dict-ref info codepoint:)

58 x: gx

59 y: gy)

60 glyphs))))))))

62;; ============================================================

63;; Main

64;; ============================================================

66(define width 600)

67(define height 300)

68(define output-path "/tmp/sigil-harfbuzz-demo.png")

70(let* ((font-path (or (find-font "sans")

71 (error "No font found — install fontconfig and fonts")))

72 (ft-library (ft-init))

73 (face (ft-new-face ft-library font-path)))

75 (display (string-append "Font: " (ft-face-family-name face)

76 " " (ft-face-style-name face) "\n"))

78 (let ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 width height))

79 (cairo-face (cairo-ft-font-face-create face 0)))

81 (with-cairo-context surface

82 (lambda (cr)

83 ;; White background

84 (cairo-set-source-rgb cr 1.0 1.0 1.0)

85 (cairo-paint cr)

87 ;; Set the FreeType font on the Cairo context

88 (cairo-set-font-face cr cairo-face)

90 ;; --- Title (large) ---

91 (ft-set-char-size face (* 32 64) 0 72 72)

92 (cairo-set-font-size cr 32.0)

93 (let ((hb-font (hb-ft-font-create face)))

94 (cairo-set-source-rgb cr 0.15 0.15 0.15)

95 (draw-shaped-text cr hb-font "HarfBuzz + Sigil" 40.0 55.0)

96 (hb-font-destroy hb-font))

98 ;; --- Subtitle ---

99 (ft-set-char-size face (* 16 64) 0 72 72)

100 (cairo-set-font-size cr 16.0)

101 (let ((hb-font (hb-ft-font-create face)))

102 (cairo-set-source-rgba cr 0.4 0.4 0.4 1.0)

103 (draw-shaped-text cr hb-font "Professional text shaping from pure Scheme" 40.0 85.0)

104 (hb-font-destroy hb-font))

105

106 ;; --- Body text samples ---

107 (ft-set-char-size face (* 18 64) 0 72 72)

108 (cairo-set-font-size cr 18.0)

109 (let ((hb-font (hb-ft-font-create face))

110 (lines '("The quick brown fox jumps over the lazy dog."

111 "ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789"

112 "Ligatures: fi fl ffi ffl — Typography!")))

113 (cairo-set-source-rgb cr 0.2 0.2 0.2)

114 (let loop ((ls lines) (y 135.0))

115 (when (pair? ls)

116 (draw-shaped-text cr hb-font (car ls) 40.0 y)

117 (loop (cdr ls) (+ y 32.0))))

118 (hb-font-destroy hb-font))

119

120 ;; --- Different sizes ---

121 (cairo-set-source-rgb cr 0.1 0.3 0.6)

122 (let loop ((sizes '(10 14 18 24)) (x 40.0))

123 (when (pair? sizes)

124 (let ((sz (car sizes)))

125 (ft-set-char-size face (* sz 64) 0 72 72)

126 (cairo-set-font-size cr (* sz 1.0))

127 (let ((hb-font (hb-ft-font-create face)))

128 (let ((next-x (draw-shaped-text cr hb-font

129 (string-append (number->string sz) "pt ")

130 x 265.0)))

131 (hb-font-destroy hb-font)

132 (loop (cdr sizes) next-x))))))))

133

134 (cairo-surface-write-to-png surface output-path)

135 (cairo-font-face-destroy cairo-face)

136 (cairo-surface-destroy surface))

137

138 (ft-done-face face)

139 (ft-done-freetype ft-library)

140 (display (string-append "Wrote " output-path "\n")))