M: cairo-demo-gadget draw-gadget* ( gadget -- )
0 0 glRasterPos2i
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 ;
: create-surface ( gadget -- cairo_surface_t )
IN: faq
: 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 -- ? )
assure-name swap tag-named? ;
: li>q/a ( li -- q/a )
[ "br" tag-named*? not ] filter
[ "strong" tag-named*? ] find-after
- >r children>> r> <q/a> ;
+ [ children>> ] dip <q/a> ;
: q/a>li ( q/a -- li )
[ question>> "strong" build-tag* f "br" build-tag* 2array ] keep
title>> [ "title" pick set-at ] when* ;
: 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> ;
: question-list>h3 ( id question-list -- h3 )
] [ drop f ] if* ;
: question-list>html ( question-list start id -- h3/f ol )
- -rot >r [ question-list>h3 ] keep
- seq>> [ q/a>li ] map "ol" build-tag* r>
+ -rot [ [ question-list>h3 ] keep seq>> [ q/a>li ] map "ol" build-tag* ] dip
number>string "start" pick set-at
"margin-left: 5em" "style" pick set-at ;
: html>faq ( div -- faq )
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 -- )
dup header>> ,
get-cba rot reg-val zero? [
2drop
] [
- >r reg-val r> set-reg
+ [ reg-val ] dip set-reg
] if f ;
: binary-op ( quot -- ? )
- >r get-cba r>
- swap >r >r [ reg-val ] bi@ swap r> call r>
+ [ get-cba ] dip
+ swap [ [ [ reg-val ] bi@ swap ] dip call ] dip
set-reg f ; inline
: op1 ( opcode -- ? )
[ swap arr-val ] binary-op ;
: 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 -- ? )
[ + >32bit ] binary-op ;
[ bitand HEX: ffffffff swap - ] binary-op ;
: new-array ( size location -- )
- >r 0 <array> r> arrays get set-nth ;
+ [ 0 <array> ] dip arrays get set-nth ;
: ?grow-storage ( -- )
open-arrays get dup empty? [
- >r arrays get length r> push
+ [ arrays get length ] dip push
] [
drop
] if ;
: op8 ( opcode -- ? )
?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 ;
: op9 ( opcode -- ? )
: canonicalize-specializer-2 ( specializer -- specializer' )
[
- >r
- {
- { [ dup integer? ] [ ] }
- { [ dup word? ] [ hooks get index ] }
- } cond args get + r>
+ [
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get +
+ ] dip
] assoc-map ;
: 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 )
[
- [ >r canonicalize-specializer-0 r> ] assoc-map
+ [ [ canonicalize-specializer-0 ] dip ] assoc-map
0 args set
V{ } clone hooks set
- [ >r canonicalize-specializer-1 r> ] assoc-map
+ [ [ canonicalize-specializer-1 ] dip ] assoc-map
hooks [ natural-sort ] change
- [ >r canonicalize-specializer-2 r> ] assoc-map
+ [ [ canonicalize-specializer-2 ] dip ] assoc-map
args get hooks get length + total set
- [ >r canonicalize-specializer-3 r> ] assoc-map
+ [ [ canonicalize-specializer-3 ] dip ] assoc-map
hooks get
] with-scope ;
inline
: topological-sort ( seq quot -- newseq )
- >r >vector [ dup empty? not ] r>
- [ dupd maximal-element >r over delete-nth r> ] curry
+ [ >vector [ dup empty? not ] ] dip
+ [ dupd maximal-element [ over delete-nth ] dip ] curry
[ ] produce nip ; inline
: classes< ( seq1 seq2 -- lt/eq/gt )
{ 0 [ [ dup ] ] }
{ 1 [ [ over ] ] }
{ 2 [ [ pick ] ] }
- [ 1- picker [ >r ] [ r> swap ] surround ]
+ [ 1- picker [ dip swap ] curry ]
} case ;
: (multi-predicate) ( class picker -- quot )
ERROR: no-method arguments generic ;
: 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 )
[ make-default-method ]
- [ drop [ >r multi-predicate r> ] assoc-map reverse ]
+ [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
2bi alist>quot ;
! Generic words
swap >>props ;
: with-methods ( word quot -- )
- over >r >r "multi-methods" word-prop
- r> call r> update-generic ; inline
+ over [
+ [ "multi-methods" word-prop ] dip call
+ ] dip update-generic ; inline
: reveal-method ( method classes generic -- )
[ set-at ] with-methods ;
syntax:M: generic definition drop f ;
PREDICATE: method-spec < array
- unclip generic? >r [ class? ] all? r> and ;
+ unclip generic? [ [ class? ] all? ] dip and ;
syntax:M: method-spec where
dup unclip method [ ] [ first ] ?if where ;
refcounts init-cache
: refcount-change ( gadget quot -- )
- >r cache-key* refcounts get
- [ [ 0 ] unless* ] r> compose change-at ;
+ [ cache-key* refcounts get [ [ 0 ] unless* ] ] dip compose change-at ;
TUPLE: cache-entry tex dims ;
C: <entry> cache-entry
gen-texture [ (render-bytes) ] keep ;
: render-bytes* ( dims bytes format -- texture dims )
- pick >r render-bytes r> ;
+ pick [ render-bytes ] dip ;
:: four-corners ( dim -- )
[let* | w [ dim first ]
dupd <2merged> swap like ;
: 3merge ( seq1 seq2 seq3 -- seq )
- pick >r <3merged> r> like ;
+ pick [ <3merged> ] dip like ;
M: merged length seqs>> [ length ] map sum ;
! Copyright (C) 2008 Doug Coleman.
! 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
: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline
-ERROR: fica-base-unknown year ;
+ERROR: fica-base-unknown ;
: fica-base-rate ( year -- x )
H{
{ 2008 102000 }
{ 2007 97500 }
- } [ fica-base-unknown ] unless-at ;
+ } at [ fica-base-unknown ] unless* ;
: fica-tax ( salary w4 -- x )
year>> fica-base-rate min fica-tax-rate * ;
! 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