Update more vocabs for >r/r> removal
parent
dbd0f865e5
commit
3d1c46417a
|
@ -25,7 +25,7 @@ TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
|
||||||
M: cairo-demo-gadget draw-gadget* ( gadget -- )
|
M: cairo-demo-gadget draw-gadget* ( gadget -- )
|
||||||
0 0 glRasterPos2i
|
0 0 glRasterPos2i
|
||||||
1.0 -1.0 glPixelZoom
|
1.0 -1.0 glPixelZoom
|
||||||
>r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
|
[ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip
|
||||||
image-array>> glDrawPixels ;
|
image-array>> glDrawPixels ;
|
||||||
|
|
||||||
: create-surface ( gadget -- cairo_surface_t )
|
: create-surface ( gadget -- cairo_surface_t )
|
||||||
|
|
|
@ -6,7 +6,7 @@ make math.parser io accessors ;
|
||||||
IN: faq
|
IN: faq
|
||||||
|
|
||||||
: find-after ( seq quot -- elem after )
|
: find-after ( seq quot -- elem after )
|
||||||
over >r find r> rot 1+ tail ; inline
|
over [ find ] dip rot 1+ tail ; inline
|
||||||
|
|
||||||
: tag-named*? ( tag name -- ? )
|
: tag-named*? ( tag name -- ? )
|
||||||
assure-name swap tag-named? ;
|
assure-name swap tag-named? ;
|
||||||
|
@ -18,7 +18,7 @@ C: <q/a> q/a
|
||||||
: li>q/a ( li -- q/a )
|
: li>q/a ( li -- q/a )
|
||||||
[ "br" tag-named*? not ] filter
|
[ "br" tag-named*? not ] filter
|
||||||
[ "strong" tag-named*? ] find-after
|
[ "strong" tag-named*? ] find-after
|
||||||
>r children>> r> <q/a> ;
|
[ children>> ] dip <q/a> ;
|
||||||
|
|
||||||
: q/a>li ( q/a -- li )
|
: q/a>li ( q/a -- li )
|
||||||
[ question>> "strong" build-tag* f "br" build-tag* 2array ] keep
|
[ question>> "strong" build-tag* f "br" build-tag* 2array ] keep
|
||||||
|
@ -48,7 +48,7 @@ C: <question-list> question-list
|
||||||
title>> [ "title" pick set-at ] when* ;
|
title>> [ "title" pick set-at ] when* ;
|
||||||
|
|
||||||
: html>question-list ( h3 ol -- question-list )
|
: html>question-list ( h3 ol -- question-list )
|
||||||
>r [ children>string ] [ f ] if* r>
|
[ [ children>string ] [ f ] if* ] dip
|
||||||
children-tags [ li>q/a ] map <question-list> ;
|
children-tags [ li>q/a ] map <question-list> ;
|
||||||
|
|
||||||
: question-list>h3 ( id question-list -- h3 )
|
: question-list>h3 ( id question-list -- h3 )
|
||||||
|
@ -58,8 +58,7 @@ C: <question-list> question-list
|
||||||
] [ drop f ] if* ;
|
] [ drop f ] if* ;
|
||||||
|
|
||||||
: question-list>html ( question-list start id -- h3/f ol )
|
: question-list>html ( question-list start id -- h3/f ol )
|
||||||
-rot >r [ question-list>h3 ] keep
|
-rot [ [ question-list>h3 ] keep seq>> [ q/a>li ] map "ol" build-tag* ] dip
|
||||||
seq>> [ q/a>li ] map "ol" build-tag* r>
|
|
||||||
number>string "start" pick set-at
|
number>string "start" pick set-at
|
||||||
"margin-left: 5em" "style" pick set-at ;
|
"margin-left: 5em" "style" pick set-at ;
|
||||||
|
|
||||||
|
@ -69,7 +68,7 @@ C: <faq> faq
|
||||||
|
|
||||||
: html>faq ( div -- faq )
|
: html>faq ( div -- faq )
|
||||||
unclip swap { "h3" "ol" } [ tags-named ] with map
|
unclip swap { "h3" "ol" } [ tags-named ] with map
|
||||||
first2 >r f prefix r> [ html>question-list ] 2map <faq> ;
|
first2 [ f prefix ] dip [ html>question-list ] 2map <faq> ;
|
||||||
|
|
||||||
: header, ( faq -- )
|
: header, ( faq -- )
|
||||||
dup header>> ,
|
dup header>> ,
|
||||||
|
|
|
@ -46,19 +46,19 @@ SYMBOL: open-arrays
|
||||||
get-cba rot reg-val zero? [
|
get-cba rot reg-val zero? [
|
||||||
2drop
|
2drop
|
||||||
] [
|
] [
|
||||||
>r reg-val r> set-reg
|
[ reg-val ] dip set-reg
|
||||||
] if f ;
|
] if f ;
|
||||||
|
|
||||||
: binary-op ( quot -- ? )
|
: binary-op ( quot -- ? )
|
||||||
>r get-cba r>
|
[ get-cba ] dip
|
||||||
swap >r >r [ reg-val ] bi@ swap r> call r>
|
swap [ [ [ reg-val ] bi@ swap ] dip call ] dip
|
||||||
set-reg f ; inline
|
set-reg f ; inline
|
||||||
|
|
||||||
: op1 ( opcode -- ? )
|
: op1 ( opcode -- ? )
|
||||||
[ swap arr-val ] binary-op ;
|
[ swap arr-val ] binary-op ;
|
||||||
|
|
||||||
: op2 ( opcode -- ? )
|
: op2 ( opcode -- ? )
|
||||||
get-cba >r [ reg-val ] bi@ r> reg-val set-arr f ;
|
get-cba [ [ reg-val ] bi@ ] dip reg-val set-arr f ;
|
||||||
|
|
||||||
: op3 ( opcode -- ? )
|
: op3 ( opcode -- ? )
|
||||||
[ + >32bit ] binary-op ;
|
[ + >32bit ] binary-op ;
|
||||||
|
@ -73,18 +73,18 @@ SYMBOL: open-arrays
|
||||||
[ bitand HEX: ffffffff swap - ] binary-op ;
|
[ bitand HEX: ffffffff swap - ] binary-op ;
|
||||||
|
|
||||||
: new-array ( size location -- )
|
: new-array ( size location -- )
|
||||||
>r 0 <array> r> arrays get set-nth ;
|
[ 0 <array> ] dip arrays get set-nth ;
|
||||||
|
|
||||||
: ?grow-storage ( -- )
|
: ?grow-storage ( -- )
|
||||||
open-arrays get dup empty? [
|
open-arrays get dup empty? [
|
||||||
>r arrays get length r> push
|
[ arrays get length ] dip push
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: op8 ( opcode -- ? )
|
: op8 ( opcode -- ? )
|
||||||
?grow-storage
|
?grow-storage
|
||||||
get-cb >r reg-val open-arrays get pop [ new-array ] keep r>
|
get-cb [ reg-val open-arrays get pop [ new-array ] keep ] dip
|
||||||
set-reg f ;
|
set-reg f ;
|
||||||
|
|
||||||
: op9 ( opcode -- ? )
|
: op9 ( opcode -- ? )
|
||||||
|
|
|
@ -31,32 +31,33 @@ SYMBOL: total
|
||||||
|
|
||||||
: canonicalize-specializer-2 ( specializer -- specializer' )
|
: canonicalize-specializer-2 ( specializer -- specializer' )
|
||||||
[
|
[
|
||||||
>r
|
[
|
||||||
{
|
{
|
||||||
{ [ dup integer? ] [ ] }
|
{ [ dup integer? ] [ ] }
|
||||||
{ [ dup word? ] [ hooks get index ] }
|
{ [ dup word? ] [ hooks get index ] }
|
||||||
} cond args get + r>
|
} cond args get +
|
||||||
|
] dip
|
||||||
] assoc-map ;
|
] assoc-map ;
|
||||||
|
|
||||||
: canonicalize-specializer-3 ( specializer -- specializer' )
|
: canonicalize-specializer-3 ( specializer -- specializer' )
|
||||||
>r total get object <array> dup <enum> r> update ;
|
[ total get object <array> dup <enum> ] dip update ;
|
||||||
|
|
||||||
: canonicalize-specializers ( methods -- methods' hooks )
|
: canonicalize-specializers ( methods -- methods' hooks )
|
||||||
[
|
[
|
||||||
[ >r canonicalize-specializer-0 r> ] assoc-map
|
[ [ canonicalize-specializer-0 ] dip ] assoc-map
|
||||||
|
|
||||||
0 args set
|
0 args set
|
||||||
V{ } clone hooks set
|
V{ } clone hooks set
|
||||||
|
|
||||||
[ >r canonicalize-specializer-1 r> ] assoc-map
|
[ [ canonicalize-specializer-1 ] dip ] assoc-map
|
||||||
|
|
||||||
hooks [ natural-sort ] change
|
hooks [ natural-sort ] change
|
||||||
|
|
||||||
[ >r canonicalize-specializer-2 r> ] assoc-map
|
[ [ canonicalize-specializer-2 ] dip ] assoc-map
|
||||||
|
|
||||||
args get hooks get length + total set
|
args get hooks get length + total set
|
||||||
|
|
||||||
[ >r canonicalize-specializer-3 r> ] assoc-map
|
[ [ canonicalize-specializer-3 ] dip ] assoc-map
|
||||||
|
|
||||||
hooks get
|
hooks get
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
@ -79,8 +80,8 @@ SYMBOL: total
|
||||||
inline
|
inline
|
||||||
|
|
||||||
: topological-sort ( seq quot -- newseq )
|
: topological-sort ( seq quot -- newseq )
|
||||||
>r >vector [ dup empty? not ] r>
|
[ >vector [ dup empty? not ] ] dip
|
||||||
[ dupd maximal-element >r over delete-nth r> ] curry
|
[ dupd maximal-element [ over delete-nth ] dip ] curry
|
||||||
[ ] produce nip ; inline
|
[ ] produce nip ; inline
|
||||||
|
|
||||||
: classes< ( seq1 seq2 -- lt/eq/gt )
|
: classes< ( seq1 seq2 -- lt/eq/gt )
|
||||||
|
@ -103,7 +104,7 @@ SYMBOL: total
|
||||||
{ 0 [ [ dup ] ] }
|
{ 0 [ [ dup ] ] }
|
||||||
{ 1 [ [ over ] ] }
|
{ 1 [ [ over ] ] }
|
||||||
{ 2 [ [ pick ] ] }
|
{ 2 [ [ pick ] ] }
|
||||||
[ 1- picker [ >r ] [ r> swap ] surround ]
|
[ 1- picker [ dip swap ] curry ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: (multi-predicate) ( class picker -- quot )
|
: (multi-predicate) ( class picker -- quot )
|
||||||
|
@ -124,11 +125,11 @@ SYMBOL: total
|
||||||
ERROR: no-method arguments generic ;
|
ERROR: no-method arguments generic ;
|
||||||
|
|
||||||
: make-default-method ( methods generic -- quot )
|
: make-default-method ( methods generic -- quot )
|
||||||
>r argument-count r> [ >r narray r> no-method ] 2curry ;
|
[ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
|
||||||
|
|
||||||
: multi-dispatch-quot ( methods generic -- quot )
|
: multi-dispatch-quot ( methods generic -- quot )
|
||||||
[ make-default-method ]
|
[ make-default-method ]
|
||||||
[ drop [ >r multi-predicate r> ] assoc-map reverse ]
|
[ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
|
||||||
2bi alist>quot ;
|
2bi alist>quot ;
|
||||||
|
|
||||||
! Generic words
|
! Generic words
|
||||||
|
@ -172,8 +173,9 @@ M: method-body crossref?
|
||||||
swap >>props ;
|
swap >>props ;
|
||||||
|
|
||||||
: with-methods ( word quot -- )
|
: with-methods ( word quot -- )
|
||||||
over >r >r "multi-methods" word-prop
|
over [
|
||||||
r> call r> update-generic ; inline
|
[ "multi-methods" word-prop ] dip call
|
||||||
|
] dip update-generic ; inline
|
||||||
|
|
||||||
: reveal-method ( method classes generic -- )
|
: reveal-method ( method classes generic -- )
|
||||||
[ set-at ] with-methods ;
|
[ set-at ] with-methods ;
|
||||||
|
@ -252,7 +254,7 @@ syntax:M: generic definer drop \ GENERIC: f ;
|
||||||
syntax:M: generic definition drop f ;
|
syntax:M: generic definition drop f ;
|
||||||
|
|
||||||
PREDICATE: method-spec < array
|
PREDICATE: method-spec < array
|
||||||
unclip generic? >r [ class? ] all? r> and ;
|
unclip generic? [ [ class? ] all? ] dip and ;
|
||||||
|
|
||||||
syntax:M: method-spec where
|
syntax:M: method-spec where
|
||||||
dup unclip method [ ] [ first ] ?if where ;
|
dup unclip method [ ] [ first ] ?if where ;
|
||||||
|
|
|
@ -23,8 +23,7 @@ textures init-cache
|
||||||
refcounts init-cache
|
refcounts init-cache
|
||||||
|
|
||||||
: refcount-change ( gadget quot -- )
|
: refcount-change ( gadget quot -- )
|
||||||
>r cache-key* refcounts get
|
[ cache-key* refcounts get [ [ 0 ] unless* ] ] dip compose change-at ;
|
||||||
[ [ 0 ] unless* ] r> compose change-at ;
|
|
||||||
|
|
||||||
TUPLE: cache-entry tex dims ;
|
TUPLE: cache-entry tex dims ;
|
||||||
C: <entry> cache-entry
|
C: <entry> cache-entry
|
||||||
|
@ -86,7 +85,7 @@ M: texture-gadget ungraft* ( gadget -- )
|
||||||
gen-texture [ (render-bytes) ] keep ;
|
gen-texture [ (render-bytes) ] keep ;
|
||||||
|
|
||||||
: render-bytes* ( dims bytes format -- texture dims )
|
: render-bytes* ( dims bytes format -- texture dims )
|
||||||
pick >r render-bytes r> ;
|
pick [ render-bytes ] dip ;
|
||||||
|
|
||||||
:: four-corners ( dim -- )
|
:: four-corners ( dim -- )
|
||||||
[let* | w [ dim first ]
|
[let* | w [ dim first ]
|
||||||
|
|
|
@ -16,7 +16,7 @@ C: <merged> merged
|
||||||
dupd <2merged> swap like ;
|
dupd <2merged> swap like ;
|
||||||
|
|
||||||
: 3merge ( seq1 seq2 seq3 -- seq )
|
: 3merge ( seq1 seq2 seq3 -- seq )
|
||||||
pick >r <3merged> r> like ;
|
pick [ <3merged> ] dip like ;
|
||||||
|
|
||||||
M: merged length seqs>> [ length ] map sum ;
|
M: merged length seqs>> [ length ] map sum ;
|
||||||
|
|
||||||
|
|
|
@ -1,17 +1,17 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs.lib math math.order money ;
|
USING: accessors math math.order money kernel assocs ;
|
||||||
IN: taxes.usa.fica
|
IN: taxes.usa.fica
|
||||||
|
|
||||||
: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline
|
: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline
|
||||||
|
|
||||||
ERROR: fica-base-unknown year ;
|
ERROR: fica-base-unknown ;
|
||||||
|
|
||||||
: fica-base-rate ( year -- x )
|
: fica-base-rate ( year -- x )
|
||||||
H{
|
H{
|
||||||
{ 2008 102000 }
|
{ 2008 102000 }
|
||||||
{ 2007 97500 }
|
{ 2007 97500 }
|
||||||
} [ fica-base-unknown ] unless-at ;
|
} at [ fica-base-unknown ] unless* ;
|
||||||
|
|
||||||
: fica-tax ( salary w4 -- x )
|
: fica-tax ( salary w4 -- x )
|
||||||
year>> fica-base-rate min fica-tax-rate * ;
|
year>> fica-base-rate min fica-tax-rate * ;
|
||||||
|
|
|
@ -2,7 +2,8 @@
|
||||||
|
|
||||||
! Thanks to Mackenzie Straight for the idea
|
! Thanks to Mackenzie Straight for the idea
|
||||||
|
|
||||||
USING: accessors kernel parser lexer words namespaces sequences quotations ;
|
USING: accessors kernel parser lexer words words.symbol
|
||||||
|
namespaces sequences quotations ;
|
||||||
|
|
||||||
IN: vars
|
IN: vars
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue