1 ! Copyright (C) 2021 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors colors combinators endian generalizations io
5 io.encodings.binary io.files io.streams.byte-array kernel math
6 math.bitwise namespaces sequences ;
12 : read-varuint ( -- n )
15 [ 0x7f bitand rot [ 7 * shift bitor ] keep 1 + swap ]
16 [ 0x80 bitand zero? not ] bi
19 : write-varuint ( n -- )
21 [ 0x7f bitand 0x80 bitor write1 ] [ -7 shift ] bi
24 : read-float32 ( -- n )
25 4 read le> bits>float ;
27 : write-float32 ( n -- )
28 float>bits 4 >le write ;
30 ERROR: invalid-length n ;
32 : write-length ( n -- )
33 dup 1 < [ invalid-length ] when 1 - write-varuint ;
37 : read-rgba-8888 ( -- rgba )
38 [ read1 255 /f ] 4 call-n <rgba> ;
40 : write-rgba-8888 ( rgba -- )
41 >rgba-components [ 255 * >integer write1 ] 4 napply ;
43 : read-rgb-565 ( -- rgba )
46 [ -5 shift 6 bits 63 /f ]
47 [ -11 shift 5 bits 31 /f ] tri
50 : write-rgb-565 ( rgba -- )
51 >rgba-components drop {
53 [ 63 * >integer 5 shift bitor ]
54 [ 31 * >integer 11 shift bitor ]
55 } spread 2 >le write ;
57 : read-rgba-f32 ( -- rgba )
58 [ read-float32 ] 4 call-n <rgba> ;
60 : write-rgba-f32 ( rgba -- )
61 >rgba-components [ write-float32 ] 4 napply ;
63 SYMBOL: color-encoding
65 : read-color ( -- color )
67 { 0 [ read-rgba-8888 ] }
68 { 1 [ read-rgb-565 ] }
69 { 2 [ read-rgba-f32 ] }
70 { 3 [ "unsupported color encoding" throw ] }
73 : write-color ( color -- )
75 { 0 [ write-rgba-8888 ] }
76 { 1 [ write-rgb-565 ] }
77 { 2 [ write-rgba-f32 ] }
78 { 3 [ "unsupported color encoding" throw ] }
85 : read-color-table ( color-count -- color-table )
86 [ read-color ] replicate ;
88 ERROR: invalid-color color-index ;
90 : check-color ( color-index -- color-index )
91 dup color-table get length <= [ invalid-color ] unless ;
93 : read-color-index ( -- color-index )
94 read-varuint check-color ;
98 SYMBOL: coordinate-range
100 : coordinate-bytes ( -- n )
101 coordinate-range get { 2 1 4 } nth ;
106 coordinate-bytes read le> scale-factor get /f ;
108 : write-unit ( n -- )
109 scale-factor get * >integer coordinate-bytes >le write ;
117 : read-point ( -- point )
118 [ read-unit ] 2 call-n <point> ;
120 : read-points ( n -- rectangles )
121 1 + [ read-point ] replicate ;
123 : write-point ( point -- )
124 [ x>> write-unit ] [ y>> write-unit ] bi ;
128 TUPLE: rectangle x y width height ;
130 C: <rectangle> rectangle
132 : read-rectangle ( -- rectangle )
133 [ read-unit ] 4 call-n <rectangle> ;
135 : read-rectangles ( n -- rectangles )
136 1 + [ read-rectangle ] replicate ;
138 : write-rectangle ( rectangle -- )
142 [ width>> write-unit ]
143 [ height>> write-unit ]
148 TUPLE: line start end ;
152 : read-line ( -- line )
153 [ read-point ] 2 call-n <line> ;
155 : read-lines ( n -- rectangles )
156 1 + [ read-line ] replicate ;
158 : write-line ( line -- )
159 [ start>> write-point ] [ end>> write-point ] bi ;
163 TUPLE: flat-colored color-index ;
165 C: <flat-colored> flat-colored
167 TUPLE: gradient point0 point1 color-index0 color-index1 ;
169 TUPLE: linear-gradient < gradient ;
171 C: <linear-gradient> linear-gradient
173 TUPLE: radial-gradient < gradient ;
175 C: <radial-gradient> radial-gradient
177 : read-gradient ( class -- style )
178 [ [ read-point ] 2 call-n [ read-color-index ] 2 call-n ] dip boa ; inline
180 : read-style ( style-kind -- style )
182 { 0 [ read-color-index <flat-colored> ] }
183 { 1 [ linear-gradient read-gradient ] }
184 { 2 [ radial-gradient read-gradient ] }
187 GENERIC: write-style ( style -- )
189 M: flat-colored write-style
190 color-index>> write-varuint ;
192 M: gradient write-style
194 [ point0>> write-point ]
195 [ point1>> write-point ]
196 [ color-index0>> write-varuint ]
197 [ color-index1>> write-varuint ]
200 : write-style-kind ( style n -- )
202 { [ dup flat-colored? ] [ drop 0 ] }
203 { [ dup linear-gradient? ] [ drop 1 ] }
204 { [ dup radial-gradient? ] [ drop 2 ] }
205 } cond 6 shift bitor write1 ;
213 TUPLE: fill fill-style ;
215 : read-fill ( style-kind -- style count )
216 read-varuint [ read-style ] dip ;
218 TUPLE: fill-polygon < fill polygon ;
220 C: <fill-polygon> fill-polygon
222 : read-fill-polygon ( style-kind -- command )
223 read-fill read-points <fill-polygon> ;
225 TUPLE: fill-rectangles < fill rectangles ;
227 C: <fill-rectangles> fill-rectangles
229 : read-fill-rectangles ( style-kind -- command )
230 read-fill read-rectangles <fill-rectangles> ;
232 TUPLE: fill-path < fill path ;
234 C: <fill-path> fill-path
236 : read-fill-path ( style-kind -- command )
237 read-fill read-path <fill-path> ;
239 TUPLE: draw-line line-style line-width ;
241 : read-draw-line ( style-kind -- line-style line-width count )
242 read-varuint [ read-style read-unit ] dip ;
244 TUPLE: draw-lines < draw-line lines ;
246 C: <draw-lines> draw-lines
248 : read-draw-lines ( style-kind -- command )
249 read-draw-line read-lines <draw-lines> ;
251 TUPLE: draw-line-loop < draw-line points ;
253 C: <draw-line-loop> draw-line-loop
255 : read-draw-line-loop ( style-kind -- command )
256 read-draw-line read-points <draw-line-loop> ;
258 TUPLE: draw-line-strip < draw-line points ;
260 C: <draw-line-strip> draw-line-strip
262 : read-draw-line-strip ( style-kind -- command )
263 read-draw-line read-points <draw-line-strip> ;
265 TUPLE: draw-line-path < draw-line path ;
267 C: <draw-line-path> draw-line-path
269 : read-draw-line-path ( style-kind -- command )
270 read-draw-line read-path <draw-line-path> ;
272 TUPLE: outline-fill fill-style line-style line-width ;
274 : read-outline-fill ( style-kind -- fill-style line-style line-width count )
275 read1 [ -6 shift ] [ 6 bits ] bi
276 [ [ read-style ] bi@ read-unit ] dip ;
278 TUPLE: outline-fill-polygon < outline-fill points ;
280 C: <outline-fill-polygon> outline-fill-polygon
282 : read-outline-fill-polygon ( style-kind -- command )
283 read-outline-fill read-points <outline-fill-polygon> ;
285 TUPLE: outline-fill-rectangles < outline-fill rectangles ;
287 C: <outline-fill-rectangles> outline-fill-rectangles
289 : read-outline-fill-rectangles ( style-kind -- command )
290 read-outline-fill read-rectangles <outline-fill-rectangles> ;
292 TUPLE: outline-fill-path < outline-fill path ;
294 C: <outline-fill-path> outline-fill-path
296 : read-outline-fill-path ( style-kind -- command )
297 read-outline-fill read-path <outline-fill-path> ;
299 : read-command ( -- command/f )
300 read1 [ -6 shift ] [ 6 bits ] bi {
301 { 0 [ 0 assert= f ] } ! end-of-document
302 { 1 [ read-fill-polygon ] }
303 { 2 [ read-fill-rectangles ] }
304 { 3 [ read-fill-path ] }
305 { 4 [ read-draw-lines ] }
306 { 5 [ read-draw-line-loop ] }
307 { 6 [ read-draw-line-strip ] }
308 { 7 [ read-draw-line-path ] }
309 { 8 [ read-outline-fill-polygon ] }
310 { 9 [ read-outline-fill-rectangles ] }
311 { 10 [ read-outline-fill-path ] }
314 : read-commands ( -- commands )
315 [ read-command dup ] [ ] produce nip ;
317 GENERIC: write-command ( command -- )
319 :: write-fill ( command n seq -- )
320 command fill-style>> n write-style-kind
321 seq length write-length
322 command fill-style>> write-style ; inline
324 M: fill-polygon write-command
325 1 over polygon>> [ write-fill ] [ [ write-point ] each ] bi ;
327 M: fill-rectangles write-command
328 2 over rectangles>> [ write-fill ] [ [ write-rectangle ] each ] bi ;
330 M: fill-path write-command
331 3 over path>> [ write-fill ] [ write-path ] bi ;
333 :: write-draw-line ( command n seq -- )
334 command line-style>> n write-style-kind
335 seq length write-length
336 command line-style>> write-style
337 command line-width>> write-unit ; inline
339 M: draw-lines write-command
340 4 over lines>> [ write-draw-line ] [ [ write-line ] each ] bi ;
342 M: draw-line-loop write-command
343 5 over points>> [ write-draw-line ] [ [ write-point ] each ] bi ;
345 M: draw-line-strip write-command
346 6 over points>> [ write-draw-line ] [ [ write-point ] each ] bi ;
348 M: draw-line-path write-command
349 7 over path>> [ write-draw-line ] [ write-path ] bi ;
351 :: write-outline-fill ( command n seq -- )
352 command fill-style>> n write-style-kind
353 command line-style>> seq length 1 - write-style-kind
354 command fill-style>> write-style
355 command line-style>> write-style
356 command line-width>> write-unit ; inline
358 M: outline-fill-polygon write-command
359 8 over points>> [ write-outline-fill ] [ [ write-point ] each ] bi ;
361 M: outline-fill-rectangles write-command
362 9 over rectangles>> [ write-outline-fill ] [ [ write-rectangle ] each ] bi ;
364 M: outline-fill-path write-command
365 10 over path>> [ write-outline-fill ] [ write-path ] bi ;
367 : write-commands ( commands -- )
368 [ write-command ] each 0 write1 ;
372 TUPLE: instruction line-width ;
374 TUPLE: diagonal-line < instruction position ;
376 C: <diagonal-line> diagonal-line
378 TUPLE: horizontal-line < instruction x ;
380 C: <horizontal-line> horizontal-line
382 TUPLE: vertical-line < instruction y ;
384 C: <vertical-line> vertical-line
386 TUPLE: cubic-bezier < instruction control0 control1 point1 ;
388 C: <cubic-bezier> cubic-bezier
390 TUPLE: arc < instruction large-arc? sweep? ;
392 TUPLE: arc-circle < arc radius target ;
394 C: <arc-circle> arc-circle
396 TUPLE: arc-ellipse < arc radius-x radius-y rotation target ;
398 C: <arc-ellipse> arc-ellipse
400 TUPLE: close-path < instruction ;
402 C: <close-path> close-path
404 TUPLE: quadratic-bezier < instruction control point1 ;
406 C: <quadratic-bezier> quadratic-bezier
408 : read-tag ( -- line-width/f tag )
409 read1 [ 4 bit? [ read-unit ] [ f ] if ] [ 3 bits ] bi ;
411 : read-arc ( -- large-arc? sweep? )
412 read1 [ 0 bit? ] [ 1 bit? ] bi ;
414 : read-instruction ( -- instruction )
416 { 0 [ read-point <diagonal-line> ] }
417 { 1 [ read-unit <horizontal-line> ] }
418 { 2 [ read-unit <vertical-line> ] }
419 { 3 [ [ read-point ] 3 call-n <cubic-bezier> ] }
420 { 4 [ read-arc read-unit read-point <arc-circle> ] }
421 { 5 [ read-arc [ read-unit ] 3 call-n read-point <arc-ellipse> ] }
422 { 6 [ <close-path> ] }
423 { 7 [ [ read-point ] 2 call-n <quadratic-bezier> ] }
426 : read-instructions ( n -- instructions )
427 1 + [ read-instruction ] replicate ;
429 : write-tag ( instruction n -- )
431 [ [ 4 set-bit ] when write1 ]
432 [ [ write-unit ] when* ] bi ;
434 : write-arc ( instruction -- )
435 [ large-arc?>> 0b1 0b0 ? ] [ sweep?>> [ 0b10 bitor ] when ] bi write1 ;
437 GENERIC: write-instruction ( instruction -- )
439 M: diagonal-line write-instruction
440 [ 0 write-tag ] [ position>> write-point ] bi ;
442 M: horizontal-line write-instruction
443 [ 1 write-tag ] [ x>> write-unit ] bi ;
445 M: vertical-line write-instruction
446 [ 2 write-tag ] [ y>> write-unit ] bi ;
448 M: cubic-bezier write-instruction
451 [ control0>> write-point ]
452 [ control1>> write-point ]
453 [ point1>> write-point ]
456 M: arc-circle write-instruction
460 [ radius>> write-unit ]
461 [ target>> write-point ]
464 M: arc-ellipse write-instruction
468 [ radius-x>> write-unit ]
469 [ radius-y>> write-unit ]
470 [ rotation>> write-unit ]
471 [ target>> write-point ]
474 M: close-path write-instruction
477 M: quadratic-bezier write-instruction
478 [ 7 write-tag ] [ control>> write-point ] [ point1>> write-point ] tri ;
482 TUPLE: segment start instructions ;
486 : read-segment ( n -- segment )
487 read-point swap read-instructions segment boa ;
489 : write-segment ( segment -- )
490 [ start>> write-point ] [ instructions>> [ write-instruction ] each ] bi ;
494 : read-path ( segment-count -- segments )
495 1 + [ read-varuint ] replicate [ read-segment ] map ;
497 : write-path ( segments -- )
498 [ [ instructions>> length write-length ] each ]
499 [ [ write-segment ] each ] bi ;
503 CONSTANT: tinyvg-magic B{ 0x72 0x56 }
505 CONSTANT: tinyvg-version 1
507 TUPLE: tinyvg scale color-encoding coordinate-range width height color-table commands ;
511 : read-tinyvg ( -- tinyvg )
514 2 read tinyvg-magic assert=
515 read1 tinyvg-version assert=
518 [ -4 shift 2 bits >>color-encoding ]
519 [ -6 shift [ >>coordinate-range ] keep ]
521 { 2 1 4 } nth '[ _ read le> ] 2 call-n
522 [ >>width ] [ >>height ] bi*
523 dup scale>> 2^ scale-factor set
524 dup color-encoding>> color-encoding set
525 dup coordinate-range>> coordinate-range set
526 read-varuint read-color-table >>color-table
527 dup color-table>> color-table set
528 read-commands >>commands
531 : path>tinyvg ( path -- tinyvg )
532 binary [ read-tinyvg ] with-file-reader ;
534 : bytes>tinyvg ( byte-array -- tinyvg )
535 binary [ read-tinyvg ] with-byte-reader ;
537 : write-tinyvg ( tinyvg -- )
540 tinyvg-version write1 {
542 [ color-encoding>> 4 shift bitor ]
543 [ coordinate-range>> 6 shift bitor write1 ]
546 [ coordinate-range>> { 2 1 4 } nth '[ _ >le write ] bi@ ]
547 [ scale>> 2^ scale-factor set ]
548 [ color-encoding>> color-encoding set ]
549 [ coordinate-range>> coordinate-range set ]
550 [ color-table>> length write-varuint ]
551 [ color-table>> [ write-color ] each ]
552 [ color-table>> color-table set ]
553 [ commands>> write-commands ]
557 : tinyvg>path ( tinyvg path -- )
558 binary [ write-tinyvg ] with-file-writer ;
560 : tinyvg>bytes ( tinyvg -- byte-array )
561 binary [ write-tinyvg ] with-byte-writer ;