Merge branch 'master' of git://repo.or.cz/factor/jcg
Doug Coleman
commit
f17c8b72ee
|
|
@ -2,19 +2,26 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences math kernel byte-arrays cairo.ffi cairo
|
||||
io.backend ui.gadgets accessors opengl.gl arrays fry
|
||||
classes ui.render namespaces ;
|
||||
|
||||
classes ui.render namespaces destructors libc ;
|
||||
IN: cairo.gadgets
|
||||
|
||||
<PRIVATE
|
||||
: width>stride ( width -- stride ) 4 * ;
|
||||
|
||||
: image-dims ( gadget -- width height stride )
|
||||
dim>> first2 over width>stride ; inline
|
||||
: image-buffer ( width height stride -- alien )
|
||||
* nip malloc ; inline
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: render-cairo* ( gadget -- )
|
||||
|
||||
: render-cairo ( gadget -- byte-array )
|
||||
dup dim>> first2 over width>stride
|
||||
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
|
||||
[ cairo_image_surface_create_for_data ] 3bi
|
||||
rot '[ _ render-cairo* ] with-cairo-from-surface ; inline
|
||||
: render-cairo ( gadget -- alien )
|
||||
[
|
||||
image-dims
|
||||
[ image-buffer dup CAIRO_FORMAT_ARGB32 ]
|
||||
[ cairo_image_surface_create_for_data ] 3bi
|
||||
] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
|
||||
|
||||
TUPLE: cairo-gadget < gadget ;
|
||||
|
||||
|
|
@ -23,11 +30,13 @@ TUPLE: cairo-gadget < gadget ;
|
|||
swap >>dim ;
|
||||
|
||||
M: cairo-gadget draw-gadget*
|
||||
[ dim>> ] [ render-cairo ] bi
|
||||
origin get first2 glRasterPos2i
|
||||
1.0 -1.0 glPixelZoom
|
||||
[ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
|
||||
glDrawPixels ;
|
||||
[
|
||||
[ dim>> ] [ render-cairo &free ] bi
|
||||
origin get first2 glRasterPos2i
|
||||
1.0 -1.0 glPixelZoom
|
||||
[ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
|
||||
glDrawPixels
|
||||
] with-destructors ;
|
||||
|
||||
: copy-surface ( surface -- )
|
||||
cr swap 0 0 cairo_set_source_surface
|
||||
|
|
|
|||
|
|
@ -604,7 +604,7 @@ HELP: MIXIN:
|
|||
|
||||
HELP: INSTANCE:
|
||||
{ $syntax "INSTANCE: instance mixin" }
|
||||
{ $values { "instance" "a class word" } { "instance" "a class word" } }
|
||||
{ $values { "instance" "a class word" } { "mixin" "a mixin class word" } }
|
||||
{ $description "Makes " { $snippet "instance" } " an instance of " { $snippet "mixin" } "." } ;
|
||||
|
||||
HELP: PREDICATE:
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax multiline ;
|
||||
IN: literals
|
||||
|
||||
HELP: $
|
||||
{ $syntax "$ word" }
|
||||
{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
|
||||
{ $notes "Since " { $snippet "word" } " is executed at parse time, " { $snippet "$" } " cannot be used with words defined in the same compilation unit." }
|
||||
{ $examples
|
||||
|
||||
{ $example <"
|
||||
USING: kernel literals prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
<< : five 5 ; >>
|
||||
{ $ five } .
|
||||
"> "{ 5 }" }
|
||||
|
||||
{ $example <"
|
||||
USING: kernel literals prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
<< : seven-eleven 7 11 ; >>
|
||||
{ $ seven-eleven } .
|
||||
"> "{ 7 11 }" }
|
||||
|
||||
} ;
|
||||
|
||||
HELP: $[
|
||||
{ $syntax "$[ code ]" }
|
||||
{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
|
||||
{ $notes "Since " { $snippet "code" } " is executed at parse time, it cannot reference any words defined in the same compilation unit." }
|
||||
{ $examples
|
||||
|
||||
{ $example <"
|
||||
USING: kernel literals math prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
<< : five 5 ; >>
|
||||
{ $[ five dup 1+ dup 2 + ] } .
|
||||
"> "{ 5 6 8 }" }
|
||||
|
||||
} ;
|
||||
|
||||
{ POSTPONE: $ POSTPONE: $[ } related-words
|
||||
|
||||
ARTICLE: "literals" "Interpolating code results into literal values"
|
||||
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
|
||||
{ $example <"
|
||||
USING: kernel literals math prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
<< : five 5 ; >>
|
||||
{ $ five $[ five dup 1+ dup 2 + ] } .
|
||||
"> "{ 5 5 6 8 }" }
|
||||
{ $subsection POSTPONE: $ }
|
||||
{ $subsection POSTPONE: $[ }
|
||||
;
|
||||
|
||||
ABOUT: "literals"
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel literals tools.test ;
|
||||
USING: kernel literals math tools.test ;
|
||||
IN: literals.tests
|
||||
|
||||
<<
|
||||
|
|
@ -10,3 +10,5 @@ IN: literals.tests
|
|||
[ { 5 } ] [ { $ five } ] unit-test
|
||||
[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
|
||||
[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
|
||||
|
||||
[ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
USING: continuations kernel parser words ;
|
||||
! (c) Joe Groff, see license for details
|
||||
USING: continuations kernel parser words quotations ;
|
||||
IN: literals
|
||||
|
||||
: $ scan-word [ execute ] curry with-datastack ; parsing
|
||||
: $[ \ ] parse-until >quotation with-datastack ; parsing
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Expression interpolation into sequence literals
|
||||
|
|
@ -0,0 +1 @@
|
|||
syntax
|
||||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
! (c)2008 Joe Groff, see BSD license etc.
|
||||
USING: help.markup help.syntax kernel math multiline sequences ;
|
||||
IN: sequences.n-based
|
||||
|
||||
HELP: <n-based-assoc>
|
||||
{ $values { "seq" sequence } { "base" integer } { "n-based-assoc" n-based-assoc } }
|
||||
{ $description "Wraps " { $snippet "seq" } " in an " { $link n-based-assoc } " wrapper." }
|
||||
{ $examples
|
||||
{ $example <"
|
||||
USING: assocs prettyprint kernel sequences.n-based ;
|
||||
IN: scratchpad
|
||||
|
||||
: months
|
||||
{
|
||||
"January"
|
||||
"February"
|
||||
"March"
|
||||
"April"
|
||||
"May"
|
||||
"June"
|
||||
"July"
|
||||
"August"
|
||||
"September"
|
||||
"October"
|
||||
"November"
|
||||
"December"
|
||||
} 1 <n-based-assoc> ;
|
||||
|
||||
10 months at .
|
||||
"> "\"October\"" } } ;
|
||||
|
||||
HELP: n-based-assoc
|
||||
{ $class-description "An adaptor class that allows a sequence to be treated as an assoc with non-zero-based keys." }
|
||||
{ $examples
|
||||
{ $example <"
|
||||
USING: assocs prettyprint kernel sequences.n-based ;
|
||||
IN: scratchpad
|
||||
|
||||
: months
|
||||
{
|
||||
"January"
|
||||
"February"
|
||||
"March"
|
||||
"April"
|
||||
"May"
|
||||
"June"
|
||||
"July"
|
||||
"August"
|
||||
"September"
|
||||
"October"
|
||||
"November"
|
||||
"December"
|
||||
} 1 <n-based-assoc> ;
|
||||
|
||||
10 months at .
|
||||
"> "\"October\"" } } ;
|
||||
|
||||
{ n-based-assoc <n-based-assoc> } related-words
|
||||
|
||||
ARTICLE: "sequences.n-based" "sequences.n-based"
|
||||
"The " { $vocab-link "sequences.n-based" } " vocabulary provides a sequence adaptor that allows a sequence to be treated as an assoc with non-zero-based keys."
|
||||
{ $subsection n-based-assoc }
|
||||
{ $subsection <n-based-assoc> }
|
||||
;
|
||||
|
||||
ABOUT: "sequences.n-based"
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
! (c)2008 Joe Groff, see BSD license etc.
|
||||
USING: kernel accessors assocs
|
||||
sequences sequences.n-based tools.test ;
|
||||
IN: sequences.n-based.tests
|
||||
|
||||
: months
|
||||
V{
|
||||
"January"
|
||||
"February"
|
||||
"March"
|
||||
"April"
|
||||
"May"
|
||||
"June"
|
||||
"July"
|
||||
"August"
|
||||
"September"
|
||||
"October"
|
||||
"November"
|
||||
"December"
|
||||
} clone 1 <n-based-assoc> ; inline
|
||||
|
||||
[ "December" t ]
|
||||
[ 12 months at* ] unit-test
|
||||
[ f f ]
|
||||
[ 13 months at* ] unit-test
|
||||
[ f f ]
|
||||
[ 0 months at* ] unit-test
|
||||
|
||||
[ 12 ] [ months assoc-size ] unit-test
|
||||
|
||||
[ {
|
||||
{ 1 "January" }
|
||||
{ 2 "February" }
|
||||
{ 3 "March" }
|
||||
{ 4 "April" }
|
||||
{ 5 "May" }
|
||||
{ 6 "June" }
|
||||
{ 7 "July" }
|
||||
{ 8 "August" }
|
||||
{ 9 "September" }
|
||||
{ 10 "October" }
|
||||
{ 11 "November" }
|
||||
{ 12 "December" }
|
||||
} ] [ months >alist ] unit-test
|
||||
|
||||
[ V{
|
||||
"January"
|
||||
"February"
|
||||
"March"
|
||||
"April"
|
||||
"May"
|
||||
"June"
|
||||
"July"
|
||||
"August"
|
||||
"September"
|
||||
"October"
|
||||
"November"
|
||||
"December"
|
||||
"Smarch"
|
||||
} ] [ "Smarch" 13 months [ set-at ] keep seq>> ] unit-test
|
||||
|
||||
[ V{ } ] [ months [ clear-assoc ] keep seq>> ] unit-test
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! (c)2008 Joe Groff, see BSD license etc.
|
||||
USING: accessors assocs kernel math math.ranges sequences
|
||||
sequences.private ;
|
||||
IN: sequences.n-based
|
||||
|
||||
TUPLE: n-based-assoc seq base ;
|
||||
C: <n-based-assoc> n-based-assoc
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: n-based@ ( key assoc -- n seq )
|
||||
[ base>> - ] [ nip seq>> ] 2bi ;
|
||||
: n-based-keys ( assoc -- range )
|
||||
[ base>> ] [ assoc-size ] bi 1 <range> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
INSTANCE: n-based-assoc assoc
|
||||
M: n-based-assoc at* ( key assoc -- value ? )
|
||||
n-based@ 2dup bounds-check?
|
||||
[ nth-unsafe t ] [ 2drop f f ] if ;
|
||||
M: n-based-assoc assoc-size ( assoc -- size )
|
||||
seq>> length ;
|
||||
M: n-based-assoc >alist ( assoc -- alist )
|
||||
[ n-based-keys ] [ seq>> ] bi zip ;
|
||||
M: n-based-assoc set-at ( value key assoc -- )
|
||||
n-based@ set-nth ;
|
||||
M: n-based-assoc delete-at ( key assoc -- )
|
||||
[ f ] 2dip n-based@ set-nth ;
|
||||
M: n-based-assoc clear-assoc ( assoc -- )
|
||||
seq>> delete-all ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sequence adaptor to treat a sequence as an n-based assoc
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
sequences
|
||||
assocs
|
||||
Loading…
Reference in New Issue