! Copyright (C) 2021 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: accessors colors combinators generalizations io io.binary
+USING: accessors colors combinators endian generalizations io
io.encodings.binary io.files io.streams.byte-array kernel math
-math.bitwise namespaces sequences ;
+math.bitwise math.functions namespaces sequences ;
IN: tinyvg
: write-length ( n -- )
dup 1 < [ invalid-length ] when 1 - write-varuint ;
-! Header
-
-CONSTANT: tinyvg-magic B{ 0x72 0x56 }
-
-CONSTANT: tinyvg-version 1
-
-TUPLE: tinyvg-header scale color-encoding coordinate-range width height color-count ;
-
-: read-tinyvg-header ( -- header )
- 2 read tinyvg-magic assert=
- read1 tinyvg-version assert=
- read1 [ 4 bits ] [ -4 shift 2 bits ] [ -6 shift ] tri
- dup { 2 1 4 } nth '[ _ read le> ] 2 call-n
- read-varuint tinyvg-header boa ;
-
-: write-tinyvg-header ( header -- )
- tinyvg-magic write
- tinyvg-version write1 {
- [ scale>> ]
- [ color-encoding>> 4 shift bitor ]
- [ coordinate-range>> 6 shift bitor write1 ]
- [ width>> ]
- [ height>> ]
- [ coordinate-range>> { 2 1 4 } nth '[ _ >le write ] bi@ ]
- [ color-count>> write-varuint ]
- } cleave ;
-
! Colors
: read-rgba-8888 ( -- rgba )
[ read1 255 /f ] 4 call-n <rgba> ;
: write-rgba-8888 ( rgba -- )
- >rgba-components [ 255 * >integer write1 ] 4 napply ;
+ >rgba-components [ 255 * round >integer write1 ] 4 napply ;
: read-rgb-565 ( -- rgba )
2 read le>
C: <flat-colored> flat-colored
-: read-flat-colored ( -- style )
- read-color-index <flat-colored> ;
-
TUPLE: gradient point0 point1 color-index0 color-index1 ;
TUPLE: linear-gradient < gradient ;
+C: <linear-gradient> linear-gradient
+
TUPLE: radial-gradient < gradient ;
+C: <radial-gradient> radial-gradient
+
: read-gradient ( class -- style )
[ [ read-point ] 2 call-n [ read-color-index ] 2 call-n ] dip boa ; inline
: read-style ( style-kind -- style )
{
- { 0 [ read-flat-colored ] }
+ { 0 [ read-color-index <flat-colored> ] }
{ 1 [ linear-gradient read-gradient ] }
{ 2 [ radial-gradient read-gradient ] }
} case ;
GENERIC: write-command ( command -- )
+:: write-fill ( command n seq -- )
+ command fill-style>> n write-style-kind
+ seq length write-length
+ command fill-style>> write-style ; inline
+
M: fill-polygon write-command
- {
- [ fill-style>> 1 write-style-kind ]
- [ polygon>> length write-length ]
- [ fill-style>> write-style ]
- [ polygon>> [ write-point ] each ]
- } cleave ;
+ 1 over polygon>> [ write-fill ] [ [ write-point ] each ] bi ;
M: fill-rectangles write-command
- {
- [ fill-style>> 2 write-style-kind ]
- [ rectangles>> length write-length ]
- [ fill-style>> write-style ]
- [ rectangles>> [ write-rectangle ] each ]
- } cleave ;
+ 2 over rectangles>> [ write-fill ] [ [ write-rectangle ] each ] bi ;
M: fill-path write-command
- {
- [ fill-style>> 3 write-style-kind ]
- [ path>> segments>> length write-length ]
- [ fill-style>> write-style ]
- [ path>> write-path ]
- } cleave ;
+ 3 over path>> [ write-fill ] [ write-path ] bi ;
+
+:: write-draw-line ( command n seq -- )
+ command line-style>> n write-style-kind
+ seq length write-length
+ command line-style>> write-style
+ command line-width>> write-unit ; inline
M: draw-lines write-command
- {
- [ line-style>> 4 write-style-kind ]
- [ lines>> length write-length ]
- [ line-style>> write-style ]
- [ line-width>> write-unit ]
- [ lines>> [ write-line ] each ]
- } cleave ;
+ 4 over lines>> [ write-draw-line ] [ [ write-line ] each ] bi ;
M: draw-line-loop write-command
- {
- [ line-style>> 5 write-style-kind ]
- [ points>> length write-length ]
- [ line-style>> write-style ]
- [ line-width>> write-unit ]
- [ points>> [ write-point ] each ]
- } cleave ;
+ 5 over points>> [ write-draw-line ] [ [ write-point ] each ] bi ;
M: draw-line-strip write-command
- {
- [ line-style>> 6 write-style-kind ]
- [ points>> length write-length ]
- [ line-style>> write-style ]
- [ line-width>> write-unit ]
- [ points>> [ write-point ] each ]
- } cleave ;
+ 6 over points>> [ write-draw-line ] [ [ write-point ] each ] bi ;
M: draw-line-path write-command
- {
- [ line-style>> 7 write-style-kind ]
- [ path>> segments>> length write-length ]
- [ line-style>> write-style ]
- [ line-width>> write-unit ]
- [ path>> write-path ]
- } cleave ;
+ 7 over path>> [ write-draw-line ] [ write-path ] bi ;
+
+:: write-outline-fill ( command n seq -- )
+ command fill-style>> n write-style-kind
+ command line-style>> seq length 1 - write-style-kind
+ command fill-style>> write-style
+ command line-style>> write-style
+ command line-width>> write-unit ; inline
M: outline-fill-polygon write-command
- {
- [ fill-style>> 8 write-style-kind ]
- [ [ line-style>> ] [ points>> length 1 - ] bi write-style-kind ]
- [ fill-style>> write-style ]
- [ line-style>> write-style ]
- [ line-width>> write-unit ]
- [ points>> [ write-point ] each ]
- } cleave ;
+ 8 over points>> [ write-outline-fill ] [ [ write-point ] each ] bi ;
M: outline-fill-rectangles write-command
- {
- [ fill-style>> 9 write-style-kind ]
- [ [ line-style>> ] [ rectangles>> length 1 - ] bi write-style-kind ]
- [ fill-style>> write-style ]
- [ line-style>> write-style ]
- [ line-width>> write-unit ]
- [ rectangles>> [ write-rectangle ] each ]
- } cleave ;
+ 9 over rectangles>> [ write-outline-fill ] [ [ write-rectangle ] each ] bi ;
M: outline-fill-path write-command
- {
- [ fill-style>> 10 write-style-kind ]
- [ [ line-style>> ] [ path>> segments>> length 1 - ] bi write-style-kind ]
- [ fill-style>> write-style ]
- [ line-style>> write-style ]
- [ line-width>> write-unit ]
- [ path>> write-path ]
- } cleave ;
+ 10 over path>> [ write-outline-fill ] [ write-path ] bi ;
: write-commands ( commands -- )
[ write-command ] each 0 write1 ;
C: <quadratic-bezier> quadratic-bezier
: read-tag ( -- line-width/f tag )
- read1 [ 4 bit? ] [ 3 bits ] bi [ [ read-unit ] [ f ] if ] dip ;
+ read1 [ 4 bit? [ read-unit ] [ f ] if ] [ 3 bits ] bi ;
: read-arc ( -- large-arc? sweep? )
read1 [ 0 bit? ] [ 1 bit? ] bi ;
: read-segment ( n -- segment )
read-point swap read-instructions segment boa ;
-: read-segments ( n -- segments )
- 1 + [ read-varuint ] replicate [ read-segment ] map ;
-
: write-segment ( segment -- )
[ start>> write-point ] [ instructions>> [ write-instruction ] each ] bi ;
-: write-segments ( segments -- )
- [ [ instructions>> length write-length ] each ]
- [ [ write-segment ] each ] bi ;
-
! Path
-TUPLE: path segments ;
+: read-path ( segment-count -- segments )
+ 1 + [ read-varuint ] replicate [ read-segment ] map ;
-C: <path> path
+: write-path ( segments -- )
+ [ [ instructions>> length write-length ] each ]
+ [ [ write-segment ] each ] bi ;
-: read-path ( segment-count -- path )
- read-segments path boa ;
+! TinyVG
-: write-path ( path -- )
- segments>> write-segments ;
+CONSTANT: tinyvg-magic B{ 0x72 0x56 }
-! TinyVG
+CONSTANT: tinyvg-version 1
-TUPLE: tinyvg header color-table commands ;
+TUPLE: tinyvg scale color-encoding coordinate-range width height color-table commands ;
C: <tinyvg> tinyvg
: read-tinyvg ( -- tinyvg )
[
- read-tinyvg-header
- dup scale>> 2^ scale-factor set
- dup color-encoding>> color-encoding set
- dup coordinate-range>> coordinate-range set
- dup color-count>> read-color-table dup color-table set
- read-commands
- <tinyvg>
+ tinyvg new
+ 2 read tinyvg-magic assert=
+ read1 tinyvg-version assert=
+ read1 {
+ [ 4 bits >>scale ]
+ [ -4 shift 2 bits >>color-encoding ]
+ [ -6 shift [ >>coordinate-range ] keep ]
+ } cleave
+ { 2 1 4 } nth '[ _ read le> ] 2 call-n
+ [ >>width ] [ >>height ] bi*
+ dup scale>> 2^ scale-factor set
+ dup color-encoding>> color-encoding set
+ dup coordinate-range>> coordinate-range set
+ read-varuint read-color-table >>color-table
+ dup color-table>> color-table set
+ read-commands >>commands
] with-scope ;
: path>tinyvg ( path -- tinyvg )
: write-tinyvg ( tinyvg -- )
[
- {
- [ header>> write-tinyvg-header ]
- [ header>> scale>> 2^ scale-factor set ]
- [ header>> color-encoding>> color-encoding set ]
- [ header>> coordinate-range>> coordinate-range set ]
- [ color-table>> color-table set ]
+ tinyvg-magic write
+ tinyvg-version write1 {
+ [ scale>> ]
+ [ color-encoding>> 4 shift bitor ]
+ [ coordinate-range>> 6 shift bitor write1 ]
+ [ width>> ]
+ [ height>> ]
+ [ coordinate-range>> { 2 1 4 } nth '[ _ >le write ] bi@ ]
+ [ scale>> 2^ scale-factor set ]
+ [ color-encoding>> color-encoding set ]
+ [ coordinate-range>> coordinate-range set ]
+ [ color-table>> length write-varuint ]
[ color-table>> [ write-color ] each ]
+ [ color-table>> color-table set ]
[ commands>> write-commands ]
} cleave
] with-scope ;
projects / factor.git / blobdiff