test/test-cairo.sgl — sigil-cairo

1;;; Cairo test suite

2;;; Requires libcairo to be installed on the system.

4(import (sigil core)

5 (sigil test)

6 (sigil fs)

7 (sigil ffi)

8 (cairo))

10(test-group "cairo"

12 (test-group "Image surfaces"

13 (test "create image surface" (fn ()

14 (let ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 100 100)))

15 (assert (pointer? surface))

16 (assert-equal CAIRO_STATUS_SUCCESS (cairo-surface-status surface))

17 (cairo-surface-destroy surface))))

19 (test "surface dimensions" (fn ()

20 (let ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 200 150)))

21 (assert-equal 200 (cairo-image-surface-get-width surface))

22 (assert-equal 150 (cairo-image-surface-get-height surface))

23 (assert-equal CAIRO_FORMAT_ARGB32 (cairo-image-surface-get-format surface))

24 (assert (> (cairo-image-surface-get-stride surface) 0))

25 (cairo-surface-destroy surface)))))

27 (test-group "Context"

28 (test "create and destroy context" (fn ()

29 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 100 100))

30 (cr (cairo-create surface)))

31 (assert (pointer? cr))

32 (assert-equal CAIRO_STATUS_SUCCESS (cairo-status cr))

33 (cairo-destroy cr)

34 (cairo-surface-destroy surface))))

36 (test "save and restore" (fn ()

37 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 100 100))

38 (cr (cairo-create surface)))

39 (cairo-set-line-width cr 5.0)

40 (cairo-save cr)

41 (cairo-set-line-width cr 10.0)

42 (cairo-restore cr)

43 (assert-equal 5.0 (cairo-get-line-width cr))

44 (cairo-destroy cr)

45 (cairo-surface-destroy surface))))

47 (test "status-to-string" (fn ()

48 (assert (string? (cairo-status-to-string CAIRO_STATUS_SUCCESS))))))

50 (test-group "Drawing"

51 (test "set-source-rgb and rectangle" (fn ()

52 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 200 200))

53 (cr (cairo-create surface)))

54 (cairo-set-source-rgb cr 0.2 0.3 0.8)

55 (cairo-rectangle cr 10.0 10.0 180.0 180.0)

56 (cairo-fill cr)

57 (assert-equal CAIRO_STATUS_SUCCESS (cairo-status cr))

58 (cairo-destroy cr)

59 (cairo-surface-destroy surface))))

61 (test "arc drawing" (fn ()

62 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 200 200))

63 (cr (cairo-create surface)))

64 (cairo-set-source-rgba cr 1.0 0.0 0.0 0.8)

65 (cairo-arc cr 100.0 100.0 50.0 0.0 6.283185)

66 (cairo-fill cr)

67 (assert-equal CAIRO_STATUS_SUCCESS (cairo-status cr))

68 (cairo-destroy cr)

69 (cairo-surface-destroy surface))))

71 (test "curve-to drawing" (fn ()

72 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 200 200))

73 (cr (cairo-create surface)))

74 (cairo-set-source-rgb cr 0.0 0.0 0.0)

75 (cairo-set-line-width cr 2.0)

76 (cairo-move-to cr 10.0 100.0)

77 (cairo-curve-to cr 50.0 10.0 150.0 190.0 190.0 100.0)

78 (cairo-stroke cr)

79 (assert-equal CAIRO_STATUS_SUCCESS (cairo-status cr))

80 (cairo-destroy cr)

81 (cairo-surface-destroy surface))))

83 (test "line drawing" (fn ()

84 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 200 200))

85 (cr (cairo-create surface)))

86 (cairo-set-source-rgb cr 0.0 0.5 0.0)

87 (cairo-set-line-width cr 3.0)

88 (cairo-move-to cr 10.0 10.0)

89 (cairo-line-to cr 190.0 190.0)

90 (cairo-stroke cr)

91 (assert-equal CAIRO_STATUS_SUCCESS (cairo-status cr))

92 (cairo-destroy cr)

93 (cairo-surface-destroy surface)))))

95 (test-group "PNG output"

96 (test "write to PNG" (fn ()

97 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 200 200))

98 (cr (cairo-create surface)))

99 (cairo-set-source-rgb cr 0.2 0.3 0.8)

100 (cairo-rectangle cr 10.0 10.0 180.0 180.0)

101 (cairo-fill cr)

102 (cairo-destroy cr)

103 (let ((status (cairo-surface-write-to-png surface "/tmp/test-cairo.png")))

104 (assert-equal CAIRO_STATUS_SUCCESS status))

105 (cairo-surface-destroy surface)

106 (assert (file-exists? "/tmp/test-cairo.png"))))))

107

108 (test-group "Text"

109 (test "text extents" (fn ()

110 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 400 200))

111 (cr (cairo-create surface)))

112 (cairo-select-font-face cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL)

113 (cairo-set-font-size cr 20.0)

114 (let ((extents (cairo-text-extents cr "Hello, Cairo!")))

115 (assert (dict? extents))

116 (assert (> (dict-ref extents 'width) 0))

117 (assert (> (dict-ref extents 'height) 0)))

118 (cairo-destroy cr)

119 (cairo-surface-destroy surface))))

120

121 (test "font extents" (fn ()

122 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 400 200))

123 (cr (cairo-create surface)))

124 (cairo-select-font-face cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL)

125 (cairo-set-font-size cr 20.0)

126 (let ((extents (cairo-font-extents cr)))

127 (assert (dict? extents))

128 (assert (> (dict-ref extents 'ascent) 0))

129 (assert (> (dict-ref extents 'height) 0)))

130 (cairo-destroy cr)

131 (cairo-surface-destroy surface)))))

132

133 (test-group "Transforms"

134 (test "translate and scale" (fn ()

135 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 200 200))

136 (cr (cairo-create surface)))

137 (cairo-translate cr 100.0 100.0)

138 (cairo-scale cr 2.0 2.0)

139 (cairo-rotate cr 0.5)

140 (cairo-identity-matrix cr)

141 (assert-equal CAIRO_STATUS_SUCCESS (cairo-status cr))

142 (cairo-destroy cr)

143 (cairo-surface-destroy surface)))))

144

145 (test-group "Patterns"

146 (test "linear gradient" (fn ()

147 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 200 200))

148 (cr (cairo-create surface))

149 (pat (cairo-pattern-create-linear 0.0 0.0 200.0 200.0)))

150 (cairo-pattern-add-color-stop-rgb pat 0.0 1.0 0.0 0.0)

151 (cairo-pattern-add-color-stop-rgb pat 1.0 0.0 0.0 1.0)

152 (cairo-set-source cr pat)

153 (cairo-paint cr)

154 (assert-equal CAIRO_STATUS_SUCCESS (cairo-status cr))

155 (cairo-pattern-destroy pat)

156 (cairo-destroy cr)

157 (cairo-surface-destroy surface))))

158

159 (test "radial gradient" (fn ()

160 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 200 200))

161 (cr (cairo-create surface))

162 (pat (cairo-pattern-create-radial 100.0 100.0 10.0 100.0 100.0 90.0)))

163 (cairo-pattern-add-color-stop-rgba pat 0.0 1.0 1.0 0.0 1.0)

164 (cairo-pattern-add-color-stop-rgba pat 1.0 0.0 0.0 1.0 0.5)

165 (cairo-set-source cr pat)

166 (cairo-paint cr)

167 (assert-equal CAIRO_STATUS_SUCCESS (cairo-status cr))

168 (cairo-pattern-destroy pat)

169 (cairo-destroy cr)

170 (cairo-surface-destroy surface)))))

171

172 (test-group "Convenience"

173 (test "with-cairo-context" (fn ()

174 (let ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 100 100)))

175 (with-cairo-context surface

176 (lambda (cr)

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

178 (cairo-paint cr)

179 (assert-equal CAIRO_STATUS_SUCCESS (cairo-status cr))))

180 (cairo-surface-destroy surface))))

181

182 (test "set-dash" (fn ()

183 (let* ((surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32 200 100))

184 (cr (cairo-create surface)))

185 (cairo-set-source-rgb cr 0.0 0.0 0.0)

186 (cairo-set-line-width cr 2.0)

187 (cairo-set-dash cr '(10.0 5.0) 0.0)

188 (cairo-move-to cr 10.0 50.0)

189 (cairo-line-to cr 190.0 50.0)

190 (cairo-stroke cr)

191 (assert-equal CAIRO_STATUS_SUCCESS (cairo-status cr))

192 (cairo-destroy cr)

193 (cairo-surface-destroy surface))))))