steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

eliminate most spins from extra

db4
Joe Groff 2009-11-05 15:34:31 -06:00
parent 08370a236d
commit 6c48852fb0
16 changed files with 63 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/bank/bank.factor
View File

@ -63,7 +63,7 @@ C: <transaction> transaction
: process-to-date ( account date -- account )
over interest-last-paid>> 1 days time+
[ dupd process-day ] spin each-day ;
[ [ dupd process-day ] ] 2dip swap each-day ;
: inserting-transactions ( account transactions -- account )
[ [ date>> process-to-date ] keep >>transaction ] each ;

10
extra/c/preprocessor/preprocessor.factor
View File

@ -93,11 +93,11 @@ ERROR: header-file-missing path ;
skip-whitespace/comments
[ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
: handle-define ( preprocessor-state sequence-parser -- )
[ take-define-identifier ]
[ skip-whitespace/comments take-rest ] bi
"\\" ?tail [ readlns append ] when
spin symbol-table>> set-at ;
:: handle-define ( preprocessor-state sequence-parser -- )
sequence-parser take-define-identifier :> ident
sequence-parser skip-whitespace/comments take-rest :> def
def "\\" ?tail [ readlns append ] when :> def
def ident preprocessor-state symbol-table>> set-at ;
: handle-undef ( preprocessor-state sequence-parser -- )
take-token swap symbol-table>> delete-at ;

9
extra/couchdb/couchdb.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations debugger hashtables http
http.client io io.encodings.string io.encodings.utf8 json.reader
json.writer kernel make math math.parser namespaces sequences strings
urls urls.encoding vectors ;
json.writer kernel locals make math math.parser namespaces sequences
strings urls urls.encoding vectors ;
IN: couchdb
! NOTE: This code only works with the latest couchdb (0.9.*), because old
@ -136,8 +136,9 @@ C: <db> db
: attachments> ( assoc -- attachments ) "_attachments" swap at ;
: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
: copy-key ( to from to-key from-key -- )
rot at spin set-at ;
:: copy-key ( to from to-key from-key -- )
from-key from at
to-key to set-at ;
: copy-id ( to from -- )
"_id" "id" copy-key ;

2
extra/digraphs/digraphs.factor
View File

@ -44,7 +44,7 @@ DEFER: (topological-sort)
] if ;
: topological-sort ( digraph -- seq )
dup clone V{ } clone spin
[ V{ } clone ] dip [ clone ] keep
[ drop (topological-sort) ] assoc-each drop reverse ;
: topological-sorted-values ( digraph -- seq )

8
extra/fries/fries.factor
View File

@ -1,11 +1,15 @@
USING: arrays vectors combinators effects kernel math sequences splitting
strings.parser parser fry sequences.extras ;
! a b c glue => acb
! c b a [ append ] dip prepend
IN: fries
: str-fry ( str on -- quot ) split
[ unclip-last [ [ spin glue ] reduce-r ] 2curry ]
[ unclip-last [ [ [ append ] [ prepend ] bi* ] reduce-r ] 2curry ]
[ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
: gen-fry ( str on -- quot ) split
[ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ]
[ unclip-last [ [ [ 1array ] [ append ] [ prepend ] tri* ] reduce-r ] 2curry ]
[ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
SYNTAX: i" parse-string rest "_" str-fry append! ;

11
extra/gpu/framebuffers/framebuffers.factor
View File

@ -157,10 +157,13 @@ M: renderbuffer framebuffer-attachment-dim
[ swap depth-attachment>> [ swap call ] [ drop ] if* ]
[ swap stencil-attachment>> [ swap call ] [ drop ] if* ] 2tri ; inline
: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
[ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ]
[ swap depth-attachment>> [ GL_DEPTH_ATTACHMENT spin call ] [ drop ] if* ]
[ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline
:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
framebuffer color-attachments>>
[| attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index
framebuffer depth-attachment>>
[| attachment | GL_DEPTH_ATTACHMENT attachment quot call ] when*
framebuffer stencil-attachment>>
[| attachment | GL_STENCIL_ATTACHMENT attachment quot call ] when* ; inline
GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- )

4
extra/jamshred/tunnel/tunnel.factor
View File

@ -77,10 +77,10 @@ CONSTANT: default-segment-radius 1
find 2drop ;
: nearest-segment-forward ( segments oint start -- segment )
rot dup length swap <slice> find-nearest-segment ;
rot tail-slice find-nearest-segment ;
: nearest-segment-backward ( segments oint start -- segment )
swapd 1 + 0 spin <slice> <reversed> find-nearest-segment ;
1 + rot head-slice <reversed> find-nearest-segment ;
: nearest-segment ( segments oint start-segment -- segment )
#! find the segment nearest to 'oint', and return it.

26
extra/koszul/koszul.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables assocs io kernel math
USING: accessors arrays hashtables assocs io kernel locals math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
splitting sorting shuffle sets math.order ;
@ -191,12 +191,12 @@ DEFER: (d)
[ ?nth ?nth ] 3keep [ [ 2 + ] dip 1 - ] dip ?nth ?nth
dim-im/ker-d ;
: bigraded-ker/im-d ( bigraded-basis -- seq )
dup length [
over first length [
[ 2dup ] dip spin (bigraded-ker/im-d)
] map 2nip
] with map ;
:: bigraded-ker/im-d ( basis -- seq )
basis length iota [| z |
basis first length iota [| u |
u z basis (bigraded-ker/im-d)
] map
] map ;
: bigraded-betti ( u-generators z-generators -- seq )
[ basis graded ] bi@ tensor bigraded-ker/im-d
@ -270,12 +270,12 @@ DEFER: (d)
3tri
3array ;
: bigraded-triples ( grid -- triples )
dup length [
over first length [
[ 2dup ] dip spin bigraded-triple
] map 2nip
] with map ;
:: bigraded-triples ( grid -- triples )
grid length [| z |
grid first length [| u |
u z grid bigraded-triple
] map
] map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq )
[ [ basis graded ] bi@ tensor bigraded-triples ] dip

1
extra/reports/noise/noise.factor
View File

@ -54,7 +54,6 @@ IN: reports.noise
{ over 2 }
{ pick 4 }
{ rot 3 }
{ spin 3 }
{ swap 1 }
{ swapd 3 }
{ tuck 2 }

6
extra/set-n/set-n.factor
View File

@ -1,9 +1,9 @@
USING: accessors assocs fry generalizations kernel math
namespaces parser sequences words ;
USING: accessors assocs fry generalizations kernel locals math
namespaces parser sequences shuffle words ;
IN: set-n
: get* ( var n -- val ) namestack dup length rot - head assoc-stack ;
: set* ( val var n -- ) 1 + namestack [ length swap - ] keep nth set-at ;
! dynamic lambda
SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ;
SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ;

15
extra/space-invaders/space-invaders.factor
View File

@ -40,12 +40,13 @@ CONSTANT: game-height 256
#! Point is a {x y}.
first2 game-width 3 * * swap 3 * + ;
: set-bitmap-pixel ( color point array -- )
#! 'color' is a {r g b}. Point is {x y}.
[ bitmap-index ] dip ! color index array
[ [ first ] 2dip set-nth ] 3keep
[ [ second ] 2dip [ 1 + ] dip set-nth ] 3keep
[ third ] 2dip [ 2 + ] dip set-nth ;
:: set-bitmap-pixel ( bitmap point color -- )
color point bitmap
point color :> index
color first index bitmap set-nth
color second index 1 + bitmap set-nth
color third index 2 + bitmap set-nth ;
: get-bitmap-pixel ( point array -- color )
#! Point is a {x y}. color is a {r g b}
@ -317,7 +318,7 @@ CONSTANT: red { 255 0 0 }
: plot-bitmap-pixel ( bitmap point color -- )
#! point is a {x y}. color is a {r g b}.
spin set-bitmap-pixel ;
set-bitmap-pixel ;
: within ( n a b -- bool )
#! n >= a and n <= b

2
extra/sudokus/sudokus.factor
View File

@ -21,7 +21,7 @@ IN: sudokus
: solution ( puzzle random? -- solution ) dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ;
: hint ( puzzle -- puzzle' ) [ [ f swap indices random dup ] [ f solution ] bi nth ] keep swapd >vector [ set-nth ] keep ;
: create ( difficulty -- puzzle ) 81 [ f ] replicate
40 random solution [ [ dup length random f spin set-nth ] curry times ] keep ;
40 random solution [ [ f swap [ length random ] keep set-nth ] curry times ] keep ;
: do-sudoku ( -- ) [ [
[

2
extra/tetris/game/game.factor
View File

@ -38,7 +38,7 @@ CONSTANT: default-height 20
level>> 1 - 60 * 1000 swap - ;
: add-block ( tetris block -- )
over board>> spin current-piece tetromino>> colour>> set-block ;
over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ;
: game-over? ( tetris -- ? )
[ board>> ] [ next-piece ] bi piece-valid? not ;

8
extra/tokyo/assoc-functor/assoc-functor.factor
View File

@ -44,11 +44,11 @@ M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ;
M: TYPE >alist ( db -- alist )
[ DBKEYS dup ] keep '[ dup _ at 2array ] map! drop ;
M: TYPE set-at ( value key db -- )
handle>> spin [ object>bytes dup length ] bi@ DBPUT drop ;
M:: TYPE set-at ( value key db -- )
db handle>> key value [ object>bytes dup length ] bi@ DBPUT drop ;
M: TYPE delete-at ( key db -- )
handle>> swap object>bytes dup length DBOUT drop ;
M:: TYPE delete-at ( key db -- )
db handle>> key object>bytes dup length DBOUT drop ;
M: TYPE clear-assoc ( db -- ) handle>> DBVANISH drop ;

5
extra/ui/gadgets/layout/layout.factor
View File

@ -23,8 +23,9 @@ TUPLE: placeholder < gadget members ;
! Just take the previous mentioned placeholder and use it
! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves
DEFER: with-interface
: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
templates get spin '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
: insertion-quot ( quot -- quot' )
make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
[ templates get ] 2dip swap '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
SYNTAX: ,% scan string>number [ <layout> , ] curry append! ;
SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] append! ;

6
extra/units/units.factor
View File

@ -28,9 +28,9 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
dimensioned boa ;
: >dimensioned< ( d -- n top bot )
[ value>> ] [ top>> ] [ bot>> ] tri ;
[ bot>> ] [ top>> ] [ value>> ] tri ;
\ <dimensioned> [ >dimensioned< ] define-inverse
\ <dimensioned> [ [ dimensioned boa ] undo ] define-inverse
: dimensions ( dimensioned -- top bot )
[ top>> ] [ bot>> ] bi ;
@ -65,7 +65,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
: d-sq ( d -- d ) dup d* ;
: d-recip ( d -- d' )
>dimensioned< spin recip dimension-op> ;
>dimensioned< recip dimension-op> ;
: d/ ( d d -- d ) d-recip d* ;