extra/tinyvg/tinyvg.factor

   1 ! Copyright (C) 2021 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors colors combinators generalizations io io.binary
   5 io.encodings.binary io.files io.streams.byte-array kernel math
   6 math.bitwise namespaces sequences ;
   7
   8 IN: tinyvg
   9
  10 ! Primitives
  11
  12 : read-varuint ( -- n )
  13     0 0 [
  14         read1
  15         [ 0x7f bitand rot [ 7 * shift bitor ] keep 1 + swap ]
  16         [ 0x80 bitand zero? not ] bi
  17     ] loop nip ;
  18
  19 : write-varuint ( n -- )
  20     [ dup 0x80 >= ] [
  21         [ 0x7f bitand 0x80 bitor write1 ] [ -7 shift ] bi
  22     ] while write1 ;
  23
  24 : read-float32 ( -- n )
  25     4 read le> bits>float ;
  26
  27 : write-float32 ( n -- )
  28     float>bits 4 >le write ;
  29
  30 ERROR: invalid-length n ;
  31
  32 : write-length ( n -- )
  33     dup 1 < [ invalid-length ] when 1 - write-varuint ;
  34
  35 ! Header
  36
  37 CONSTANT: tinyvg-magic B{ 0x72 0x56 }
  38
  39 CONSTANT: tinyvg-version 1
  40
  41 TUPLE: tinyvg-header scale color-encoding coordinate-range width height color-count ;
  42
  43 : read-tinyvg-header ( -- header )
  44     2 read tinyvg-magic assert=
  45     read1 tinyvg-version assert=
  46     read1 [ 4 bits ] [ -4 shift 2 bits ] [ -6 shift ] tri
  47     dup { 2 1 4 } nth '[ _ read le> ] 2 call-n
  48     read-varuint tinyvg-header boa ;
  49
  50 : write-tinyvg-header ( header -- )
  51     tinyvg-magic write
  52     tinyvg-version write1 {
  53         [ scale>> ]
  54         [ color-encoding>> 4 shift bitor ]
  55         [ coordinate-range>> 6 shift bitor write1 ]
  56         [ width>> ]
  57         [ height>> ]
  58         [ coordinate-range>> { 2 1 4 } nth '[ _ >le write ] bi@ ]
  59         [ color-count>> write-varuint ]
  60     } cleave ;
  61
  62 ! Colors
  63
  64 : read-rgba-8888 ( -- rgba )
  65     [ read1 255 /f ] 4 call-n <rgba> ;
  66
  67 : write-rgba-8888 ( rgba -- )
  68     >rgba-components [ 255 * >integer write1 ] 4 napply ;
  69
  70 : read-rgb-565 ( -- rgba )
  71     2 read le>
  72     [ 5 bits 31 /f ]
  73     [ -5 shift 6 bits 63 /f ]
  74     [ -11 shift 5 bits 31 /f ] tri
  75     1.0 <rgba> ;
  76
  77 : write-rgb-565 ( rgba -- )
  78     >rgba-components drop {
  79         [ 31 * >integer ]
  80         [ 63 * >integer 5 shift bitor ]
  81         [ 31 * >integer 11 shift bitor ]
  82     } spread 2 >le write ;
  83
  84 : read-rgba-f32 ( -- rgba )
  85     [ read-float32 ] 4 call-n <rgba> ;
  86
  87 : write-rgba-f32 ( rgba -- )
  88     >rgba-components [ write-float32 ] 4 napply ;
  89
  90 SYMBOL: color-encoding
  91
  92 : read-color ( -- color )
  93     color-encoding get {
  94         { 0 [ read-rgba-8888 ] }
  95         { 1 [ read-rgb-565 ] }
  96         { 2 [ read-rgba-f32 ] }
  97         { 3 [ "unsupported color encoding" throw ] }
  98     } case ;
  99
 100 : write-color ( color -- )
 101     color-encoding get {
 102         { 0 [ write-rgba-8888 ] }
 103         { 1 [ write-rgb-565 ] }
 104         { 2 [ write-rgba-f32 ] }
 105         { 3 [ "unsupported color encoding" throw ] }
 106     } case ;
 107
 108 ! Color Table
 109
 110 SYMBOL: color-table
 111
 112 : read-color-table ( color-count -- color-table )
 113     [ read-color ] replicate ;
 114
 115 ERROR: invalid-color color-index ;
 116
 117 : check-color ( color-index -- color-index )
 118     dup color-table get length <= [ invalid-color ] unless ;
 119
 120 : read-color-index ( -- color-index )
 121     read-varuint check-color ;
 122
 123 ! Coordinates
 124
 125 SYMBOL: coordinate-range
 126
 127 : coordinate-bytes ( -- n )
 128     coordinate-range get { 2 1 4 } nth ;
 129
 130 SYMBOL: scale-factor
 131
 132 : read-unit ( -- n )
 133     coordinate-bytes read le> scale-factor get /f ;
 134
 135 : write-unit ( n -- )
 136     scale-factor get * >integer coordinate-bytes >le write ;
 137
 138 ! Point
 139
 140 TUPLE: point x y ;
 141
 142 C: <point> point
 143
 144 : read-point ( -- point )
 145     [ read-unit ] 2 call-n <point> ;
 146
 147 : read-points ( n -- rectangles )
 148     1 + [ read-point ] replicate ;
 149
 150 : write-point ( point -- )
 151     [ x>> write-unit ] [ y>> write-unit ] bi ;
 152
 153 ! Rectangle
 154
 155 TUPLE: rectangle x y width height ;
 156
 157 C: <rectangle> rectangle
 158
 159 : read-rectangle ( -- rectangle )
 160     [ read-unit ] 4 call-n <rectangle> ;
 161
 162 : read-rectangles ( n -- rectangles )
 163     1 + [ read-rectangle ] replicate ;
 164
 165 : write-rectangle ( rectangle -- )
 166     {
 167         [ x>> write-unit ]
 168         [ y>> write-unit ]
 169         [ width>> write-unit ]
 170         [ height>> write-unit ]
 171     } cleave ;
 172
 173 ! Line
 174
 175 TUPLE: line start end ;
 176
 177 C: <line> line
 178
 179 : read-line ( -- line )
 180     [ read-point ] 2 call-n <line> ;
 181
 182 : read-lines ( n -- rectangles )
 183     1 + [ read-line ] replicate ;
 184
 185 : write-line ( line -- )
 186     [ start>> write-point ] [ end>> write-point ] bi ;
 187
 188 ! Styles
 189
 190 TUPLE: flat-colored color-index ;
 191
 192 C: <flat-colored> flat-colored
 193
 194 : read-flat-colored ( -- style )
 195     read-color-index <flat-colored> ;
 196
 197 TUPLE: gradient point0 point1 color-index0 color-index1 ;
 198
 199 TUPLE: linear-gradient < gradient ;
 200
 201 TUPLE: radial-gradient < gradient ;
 202
 203 : read-gradient ( class -- style )
 204     [ [ read-point ] 2 call-n [ read-color-index ] 2 call-n ] dip boa ; inline
 205
 206 : read-style ( style-kind -- style )
 207     {
 208         { 0 [ read-flat-colored ] }
 209         { 1 [ linear-gradient read-gradient ] }
 210         { 2 [ radial-gradient read-gradient ] }
 211     } case ;
 212
 213 GENERIC: write-style ( style -- )
 214
 215 M: flat-colored write-style
 216     color-index>> write-varuint ;
 217
 218 M: gradient write-style
 219     {
 220         [ point0>> write-point ]
 221         [ point1>> write-point ]
 222         [ color-index0>> write-varuint ]
 223         [ color-index1>> write-varuint ]
 224     } cleave ;
 225
 226 : write-style-kind ( style n -- )
 227     swap {
 228         { [ dup flat-colored? ] [ drop 0 ] }
 229         { [ dup linear-gradient? ] [ drop 1 ] }
 230         { [ dup radial-gradient? ] [ drop 2 ] }
 231     } cond 6 shift bitor write1 ;
 232
 233 ! Commands
 234
 235 DEFER: read-path
 236
 237 DEFER: write-path
 238
 239 TUPLE: fill fill-style ;
 240
 241 : read-fill ( style-kind -- style count )
 242     read-varuint [ read-style ] dip ;
 243
 244 TUPLE: fill-polygon < fill polygon ;
 245
 246 C: <fill-polygon> fill-polygon
 247
 248 : read-fill-polygon ( style-kind -- command )
 249     read-fill read-points <fill-polygon> ;
 250
 251 TUPLE: fill-rectangles < fill rectangles ;
 252
 253 C: <fill-rectangles> fill-rectangles
 254
 255 : read-fill-rectangles ( style-kind -- command )
 256     read-fill read-rectangles <fill-rectangles> ;
 257
 258 TUPLE: fill-path < fill path ;
 259
 260 C: <fill-path> fill-path
 261
 262 : read-fill-path ( style-kind -- command )
 263     read-fill read-path <fill-path> ;
 264
 265 TUPLE: draw-line line-style line-width ;
 266
 267 : read-draw-line ( style-kind -- line-style line-width count )
 268     read-varuint [ read-style read-unit ] dip ;
 269
 270 TUPLE: draw-lines < draw-line lines ;
 271
 272 C: <draw-lines> draw-lines
 273
 274 : read-draw-lines ( style-kind -- command )
 275     read-draw-line read-lines <draw-lines> ;
 276
 277 TUPLE: draw-line-loop < draw-line points ;
 278
 279 C: <draw-line-loop> draw-line-loop
 280
 281 : read-draw-line-loop ( style-kind -- command )
 282     read-draw-line read-points <draw-line-loop> ;
 283
 284 TUPLE: draw-line-strip < draw-line points ;
 285
 286 C: <draw-line-strip> draw-line-strip
 287
 288 : read-draw-line-strip ( style-kind -- command )
 289     read-draw-line read-points <draw-line-strip> ;
 290
 291 TUPLE: draw-line-path < draw-line path ;
 292
 293 C: <draw-line-path> draw-line-path
 294
 295 : read-draw-line-path ( style-kind -- command )
 296     read-draw-line read-path <draw-line-path> ;
 297
 298 TUPLE: outline-fill fill-style line-style line-width ;
 299
 300 : read-outline-fill ( style-kind -- fill-style line-style line-width count )
 301     read1 [ -6 shift ] [ 6 bits ] bi
 302     [ [ read-style ] bi@ read-unit ] dip ;
 303
 304 TUPLE: outline-fill-polygon < outline-fill points ;
 305
 306 C: <outline-fill-polygon> outline-fill-polygon
 307
 308 : read-outline-fill-polygon ( style-kind -- command )
 309     read-outline-fill read-points <outline-fill-polygon> ;
 310
 311 TUPLE: outline-fill-rectangles < outline-fill rectangles ;
 312
 313 C: <outline-fill-rectangles> outline-fill-rectangles
 314
 315 : read-outline-fill-rectangles ( style-kind -- command )
 316     read-outline-fill read-rectangles <outline-fill-rectangles> ;
 317
 318 TUPLE: outline-fill-path < outline-fill path ;
 319
 320 C: <outline-fill-path> outline-fill-path
 321
 322 : read-outline-fill-path ( style-kind -- command )
 323     read-outline-fill read-path <outline-fill-path> ;
 324
 325 : read-command ( -- command/f )
 326     read1 [ -6 shift ] [ 6 bits ] bi {
 327         { 0 [ 0 assert= f ] } ! end-of-document
 328         { 1 [ read-fill-polygon ] }
 329         { 2 [ read-fill-rectangles ] }
 330         { 3 [ read-fill-path ] }
 331         { 4 [ read-draw-lines ] }
 332         { 5 [ read-draw-line-loop ] }
 333         { 6 [ read-draw-line-strip ] }
 334         { 7 [ read-draw-line-path ] }
 335         { 8 [ read-outline-fill-polygon ] }
 336         { 9 [ read-outline-fill-rectangles ] }
 337         { 10 [ read-outline-fill-path ] }
 338     } case ;
 339
 340 : read-commands ( -- commands )
 341     [ read-command dup ] [ ] produce nip ;
 342
 343 GENERIC: write-command ( command -- )
 344
 345 :: write-fill ( command n seq -- )
 346     command fill-style>> n write-style-kind
 347     seq length write-length
 348     command fill-style>> write-style ; inline
 349
 350 M: fill-polygon write-command
 351     1 over polygon>> [ write-fill ] [ [ write-point ] each ] bi ;
 352
 353 M: fill-rectangles write-command
 354     2 over rectangles>> [ write-fill ] [ [ write-rectangle ] each ] bi ;
 355
 356 M: fill-path write-command
 357     3 over path>> [ write-fill ] [ write-path ] bi ;
 358
 359 :: write-draw-line ( command n seq -- )
 360     command line-style>> n write-style-kind
 361     seq length write-length
 362     command line-style>> write-style
 363     command line-width>> write-unit ; inline
 364
 365 M: draw-lines write-command
 366     4 over lines>> [ write-draw-line ] [ [ write-line ] each ] bi ;
 367
 368 M: draw-line-loop write-command
 369     5 over points>> [ write-draw-line ] [ [ write-point ] each ] bi ;
 370
 371 M: draw-line-strip write-command
 372     6 over points>> [ write-draw-line ] [ [ write-point ] each ] bi ;
 373
 374 M: draw-line-path write-command
 375     7 over path>> [ write-draw-line ] [ write-path ] bi ;
 376
 377 :: write-outline-fill ( command n seq -- )
 378     command fill-style>> n write-style-kind
 379     command line-style>> seq length 1 - write-style-kind
 380     command fill-style>> write-style
 381     command line-style>> write-style
 382     command line-width>> write-unit ; inline
 383
 384 M: outline-fill-polygon write-command
 385     8 over points>> [ write-outline-fill ] [ [ write-point ] each ] bi ;
 386
 387 M: outline-fill-rectangles write-command
 388     9 over rectangles>> [ write-outline-fill ] [ [ write-rectangle ] each ] bi ;
 389
 390 M: outline-fill-path write-command
 391     10 over path>> [ write-outline-fill ] [ write-path ] bi ;
 392
 393 : write-commands ( commands -- )
 394     [ write-command ] each 0 write1 ;
 395
 396 ! Nodes
 397
 398 TUPLE: instruction line-width ;
 399
 400 TUPLE: diagonal-line < instruction position ;
 401
 402 C: <diagonal-line> diagonal-line
 403
 404 TUPLE: horizontal-line < instruction x ;
 405
 406 C: <horizontal-line> horizontal-line
 407
 408 TUPLE: vertical-line < instruction y ;
 409
 410 C: <vertical-line> vertical-line
 411
 412 TUPLE: cubic-bezier < instruction control0 control1 point1 ;
 413
 414 C: <cubic-bezier> cubic-bezier
 415
 416 TUPLE: arc < instruction large-arc? sweep? ;
 417
 418 TUPLE: arc-circle < arc radius target ;
 419
 420 C: <arc-circle> arc-circle
 421
 422 TUPLE: arc-ellipse < arc radius-x radius-y rotation target ;
 423
 424 C: <arc-ellipse> arc-ellipse
 425
 426 TUPLE: close-path < instruction ;
 427
 428 C: <close-path> close-path
 429
 430 TUPLE: quadratic-bezier < instruction control point1 ;
 431
 432 C: <quadratic-bezier> quadratic-bezier
 433
 434 : read-tag ( -- line-width/f tag )
 435     read1 [ 4 bit? ] [ 3 bits ] bi [ [ read-unit ] [ f ] if ] dip ;
 436
 437 : read-arc ( -- large-arc? sweep? )
 438     read1 [ 0 bit? ] [ 1 bit? ] bi ;
 439
 440 : read-instruction ( -- instruction )
 441     read-tag {
 442         { 0 [ read-point <diagonal-line> ] }
 443         { 1 [ read-unit <horizontal-line> ] }
 444         { 2 [ read-unit <vertical-line> ] }
 445         { 3 [ [ read-point ] 3 call-n <cubic-bezier> ] }
 446         { 4 [ read-arc read-unit read-point <arc-circle> ] }
 447         { 5 [ read-arc [ read-unit ] 3 call-n read-point <arc-ellipse> ] }
 448         { 6 [ <close-path> ] }
 449         { 7 [ [ read-point ] 2 call-n <quadratic-bezier> ] }
 450     } case ;
 451
 452 : read-instructions ( n -- instructions )
 453     1 + [ read-instruction ] replicate ;
 454
 455 : write-tag ( instruction n -- )
 456     swap line-width>>
 457     [ [ 4 set-bit ] when write1 ]
 458     [ [ write-unit ] when* ] bi ;
 459
 460 : write-arc ( instruction -- )
 461     [ large-arc?>> 0b1 0b0 ? ] [ sweep?>> [ 0b10 bitor ] when ] bi write1 ;
 462
 463 GENERIC: write-instruction ( instruction -- )
 464
 465 M: diagonal-line write-instruction
 466     [ 0 write-tag ] [ position>> write-point ] bi ;
 467
 468 M: horizontal-line write-instruction
 469     [ 1 write-tag ] [ x>> write-unit ] bi ;
 470
 471 M: vertical-line write-instruction
 472     [ 2 write-tag ] [ y>> write-unit ] bi ;
 473
 474 M: cubic-bezier write-instruction
 475     {
 476         [ 3 write-tag ]
 477         [ control0>> write-point ]
 478         [ control1>> write-point ]
 479         [ point1>> write-point ]
 480     } cleave ;
 481
 482 M: arc-circle write-instruction
 483     {
 484         [ 4 write-tag ]
 485         [ write-arc ]
 486         [ radius>> write-unit ]
 487         [ target>> write-point ]
 488     } cleave ;
 489
 490 M: arc-ellipse write-instruction
 491     {
 492         [ 5 write-tag ]
 493         [ write-arc ]
 494         [ radius-x>> write-unit ]
 495         [ radius-y>> write-unit ]
 496         [ rotation>> write-unit ]
 497         [ target>> write-point ]
 498     } cleave ;
 499
 500 M: close-path write-instruction
 501     6 write-tag ;
 502
 503 M: quadratic-bezier write-instruction
 504     [ 7 write-tag ] [ control>> write-point ] [ point1>> write-point ] tri ;
 505
 506 ! Segment
 507
 508 TUPLE: segment start instructions ;
 509
 510 C: <segment> segment
 511
 512 : read-segment ( n -- segment )
 513     read-point swap read-instructions segment boa ;
 514
 515 : write-segment ( segment -- )
 516     [ start>> write-point ] [ instructions>> [ write-instruction ] each ] bi ;
 517
 518 ! Path
 519
 520 : read-path ( segment-count -- segments )
 521     1 + [ read-varuint ] replicate [ read-segment ] map ;
 522
 523 : write-path ( segments -- )
 524     [ [ instructions>> length write-length ] each ]
 525     [ [ write-segment ] each ] bi ;
 526
 527 ! TinyVG
 528
 529 TUPLE: tinyvg header color-table commands ;
 530
 531 C: <tinyvg> tinyvg
 532
 533 : read-tinyvg ( -- tinyvg )
 534     [
 535         read-tinyvg-header
 536         dup scale>> 2^ scale-factor set
 537         dup color-encoding>> color-encoding set
 538         dup coordinate-range>> coordinate-range set
 539         dup color-count>> read-color-table dup color-table set
 540         read-commands
 541         <tinyvg>
 542     ] with-scope ;
 543
 544 : path>tinyvg ( path -- tinyvg )
 545     binary [ read-tinyvg ] with-file-reader ;
 546
 547 : bytes>tinyvg ( byte-array -- tinyvg )
 548     binary [ read-tinyvg ] with-byte-reader ;
 549
 550 : write-tinyvg ( tinyvg -- )
 551     [
 552         {
 553             [ header>> write-tinyvg-header ]
 554             [ header>> scale>> 2^ scale-factor set ]
 555             [ header>> color-encoding>> color-encoding set ]
 556             [ header>> coordinate-range>> coordinate-range set ]
 557             [ color-table>> color-table set ]
 558             [ color-table>> [ write-color ] each ]
 559             [ commands>> write-commands ]
 560         } cleave
 561     ] with-scope ;
 562
 563 : tinyvg>path ( tinyvg path -- )
 564     binary [ write-tinyvg ] with-file-writer ;
 565
 566 : tinyvg>bytes ( tinyvg -- byte-array )
 567     binary [ write-tinyvg ] with-byte-writer ;