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 M: fill-polygon write-command
 346     {
 347         [ fill-style>> 1 write-style-kind ]
 348         [ polygon>> length write-length ]
 349         [ fill-style>> write-style ]
 350         [ polygon>> [ write-point ] each ]
 351     } cleave ;
 352
 353 M: fill-rectangles write-command
 354     {
 355         [ fill-style>> 2 write-style-kind ]
 356         [ rectangles>> length write-length ]
 357         [ fill-style>> write-style ]
 358         [ rectangles>> [ write-rectangle ] each ]
 359     } cleave ;
 360
 361 M: fill-path write-command
 362     {
 363         [ fill-style>> 3 write-style-kind ]
 364         [ path>> segments>> length write-length ]
 365         [ fill-style>> write-style ]
 366         [ path>> write-path ]
 367     } cleave ;
 368
 369 M: draw-lines write-command
 370     {
 371         [ line-style>> 4 write-style-kind ]
 372         [ lines>> length write-length ]
 373         [ line-style>> write-style ]
 374         [ line-width>> write-unit ]
 375         [ lines>> [ write-line ] each ]
 376     } cleave ;
 377
 378 M: draw-line-loop write-command
 379     {
 380         [ line-style>> 5 write-style-kind ]
 381         [ points>> length write-length ]
 382         [ line-style>> write-style ]
 383         [ line-width>> write-unit ]
 384         [ points>> [ write-point ] each ]
 385     } cleave ;
 386
 387 M: draw-line-strip write-command
 388     {
 389         [ line-style>> 6 write-style-kind ]
 390         [ points>> length write-length ]
 391         [ line-style>> write-style ]
 392         [ line-width>> write-unit ]
 393         [ points>> [ write-point ] each ]
 394     } cleave ;
 395
 396 M: draw-line-path write-command
 397     {
 398         [ line-style>> 7 write-style-kind ]
 399         [ path>> segments>> length write-length ]
 400         [ line-style>> write-style ]
 401         [ line-width>> write-unit ]
 402         [ path>> write-path ]
 403     } cleave ;
 404
 405 M: outline-fill-polygon write-command
 406     {
 407         [ fill-style>> 8 write-style-kind ]
 408         [ [ line-style>> ] [ points>> length 1 - ] bi write-style-kind ]
 409         [ fill-style>> write-style ]
 410         [ line-style>> write-style ]
 411         [ line-width>> write-unit ]
 412         [ points>> [ write-point ] each ]
 413     } cleave ;
 414
 415 M: outline-fill-rectangles write-command
 416     {
 417         [ fill-style>> 9 write-style-kind ]
 418         [ [ line-style>> ] [ rectangles>> length 1 - ] bi write-style-kind ]
 419         [ fill-style>> write-style ]
 420         [ line-style>> write-style ]
 421         [ line-width>> write-unit ]
 422         [ rectangles>> [ write-rectangle ] each ]
 423     } cleave ;
 424
 425 M: outline-fill-path write-command
 426     {
 427         [ fill-style>> 10 write-style-kind ]
 428         [ [ line-style>> ] [ path>> segments>> length 1 - ] bi write-style-kind ]
 429         [ fill-style>> write-style ]
 430         [ line-style>> write-style ]
 431         [ line-width>> write-unit ]
 432         [ path>> write-path ]
 433     } cleave ;
 434
 435 : write-commands ( commands -- )
 436     [ write-command ] each 0 write1 ;
 437
 438 ! Nodes
 439
 440 TUPLE: instruction line-width ;
 441
 442 TUPLE: diagonal-line < instruction position ;
 443
 444 C: <diagonal-line> diagonal-line
 445
 446 TUPLE: horizontal-line < instruction x ;
 447
 448 C: <horizontal-line> horizontal-line
 449
 450 TUPLE: vertical-line < instruction y ;
 451
 452 C: <vertical-line> vertical-line
 453
 454 TUPLE: cubic-bezier < instruction control0 control1 point1 ;
 455
 456 C: <cubic-bezier> cubic-bezier
 457
 458 TUPLE: arc < instruction large-arc? sweep? ;
 459
 460 TUPLE: arc-circle < arc radius target ;
 461
 462 C: <arc-circle> arc-circle
 463
 464 TUPLE: arc-ellipse < arc radius-x radius-y rotation target ;
 465
 466 C: <arc-ellipse> arc-ellipse
 467
 468 TUPLE: close-path < instruction ;
 469
 470 C: <close-path> close-path
 471
 472 TUPLE: quadratic-bezier < instruction control point1 ;
 473
 474 C: <quadratic-bezier> quadratic-bezier
 475
 476 : read-tag ( -- line-width/f tag )
 477     read1 [ 4 bit? ] [ 3 bits ] bi [ [ read-unit ] [ f ] if ] dip ;
 478
 479 : read-arc ( -- large-arc? sweep? )
 480     read1 [ 0 bit? ] [ 1 bit? ] bi ;
 481
 482 : read-instruction ( -- instruction )
 483     read-tag {
 484         { 0 [ read-point <diagonal-line> ] }
 485         { 1 [ read-unit <horizontal-line> ] }
 486         { 2 [ read-unit <vertical-line> ] }
 487         { 3 [ [ read-point ] 3 call-n <cubic-bezier> ] }
 488         { 4 [ read-arc read-unit read-point <arc-circle> ] }
 489         { 5 [ read-arc [ read-unit ] 3 call-n read-point <arc-ellipse> ] }
 490         { 6 [ <close-path> ] }
 491         { 7 [ [ read-point ] 2 call-n <quadratic-bezier> ] }
 492     } case ;
 493
 494 : read-instructions ( n -- instructions )
 495     1 + [ read-instruction ] replicate ;
 496
 497 : write-tag ( instruction n -- )
 498     swap line-width>>
 499     [ [ 4 set-bit ] when write1 ]
 500     [ [ write-unit ] when* ] bi ;
 501
 502 : write-arc ( instruction -- )
 503     [ large-arc?>> 0b1 0b0 ? ] [ sweep?>> [ 0b10 bitor ] when ] bi write1 ;
 504
 505 GENERIC: write-instruction ( instruction -- )
 506
 507 M: diagonal-line write-instruction
 508     [ 0 write-tag ] [ position>> write-point ] bi ;
 509
 510 M: horizontal-line write-instruction
 511     [ 1 write-tag ] [ x>> write-unit ] bi ;
 512
 513 M: vertical-line write-instruction
 514     [ 2 write-tag ] [ y>> write-unit ] bi ;
 515
 516 M: cubic-bezier write-instruction
 517     {
 518         [ 3 write-tag ]
 519         [ control0>> write-point ]
 520         [ control1>> write-point ]
 521         [ point1>> write-point ]
 522     } cleave ;
 523
 524 M: arc-circle write-instruction
 525     {
 526         [ 4 write-tag ]
 527         [ write-arc ]
 528         [ radius>> write-unit ]
 529         [ target>> write-point ]
 530     } cleave ;
 531
 532 M: arc-ellipse write-instruction
 533     {
 534         [ 5 write-tag ]
 535         [ write-arc ]
 536         [ radius-x>> write-unit ]
 537         [ radius-y>> write-unit ]
 538         [ rotation>> write-unit ]
 539         [ target>> write-point ]
 540     } cleave ;
 541
 542 M: close-path write-instruction
 543     6 write-tag ;
 544
 545 M: quadratic-bezier write-instruction
 546     [ 7 write-tag ] [ control>> write-point ] [ point1>> write-point ] tri ;
 547
 548 ! Segment
 549
 550 TUPLE: segment start instructions ;
 551
 552 C: <segment> segment
 553
 554 : read-segment ( n -- segment )
 555     read-point swap read-instructions segment boa ;
 556
 557 : read-segments ( n -- segments )
 558     1 + [ read-varuint ] replicate [ read-segment ] map ;
 559
 560 : write-segment ( segment -- )
 561     [ start>> write-point ] [ instructions>> [ write-instruction ] each ] bi ;
 562
 563 : write-segments ( segments -- )
 564     [ [ instructions>> length write-length ] each ]
 565     [ [ write-segment ] each ] bi ;
 566
 567 ! Path
 568
 569 TUPLE: path segments ;
 570
 571 C: <path> path
 572
 573 : read-path ( segment-count -- path )
 574     read-segments path boa ;
 575
 576 : write-path ( path -- )
 577     segments>> write-segments ;
 578
 579 ! TinyVG
 580
 581 TUPLE: tinyvg header color-table commands ;
 582
 583 C: <tinyvg> tinyvg
 584
 585 : read-tinyvg ( -- tinyvg )
 586     [
 587         read-tinyvg-header
 588         dup scale>> 2^ scale-factor set
 589         dup color-encoding>> color-encoding set
 590         dup coordinate-range>> coordinate-range set
 591         dup color-count>> read-color-table dup color-table set
 592         read-commands
 593         <tinyvg>
 594     ] with-scope ;
 595
 596 : path>tinyvg ( path -- tinyvg )
 597     binary [ read-tinyvg ] with-file-reader ;
 598
 599 : bytes>tinyvg ( byte-array -- tinyvg )
 600     binary [ read-tinyvg ] with-byte-reader ;
 601
 602 : write-tinyvg ( tinyvg -- )
 603     [
 604         {
 605             [ header>> write-tinyvg-header ]
 606             [ header>> scale>> 2^ scale-factor set ]
 607             [ header>> color-encoding>> color-encoding set ]
 608             [ header>> coordinate-range>> coordinate-range set ]
 609             [ color-table>> color-table set ]
 610             [ color-table>> [ write-color ] each ]
 611             [ commands>> write-commands ]
 612         } cleave
 613     ] with-scope ;
 614
 615 : tinyvg>path ( tinyvg path -- )
 616     binary [ write-tinyvg ] with-file-writer ;
 617
 618 : tinyvg>bytes ( tinyvg -- byte-array )
 619     binary [ write-tinyvg ] with-byte-writer ;