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