eliminate most spins from extra

extra/bank/bank.factor

@@ -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 ;

extra/c/preprocessor/preprocessor.factor

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

extra/couchdb/couchdb.factor

@@ -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
+json.writer kernel locals make math math.parser namespaces sequences
-urls urls.encoding vectors ;
+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 -- )
+:: copy-key ( to from to-key from-key -- )
-    rot at spin set-at ;
+    from-key from at
+    to-key to set-at ;
 
 : copy-id ( to from -- )
     "_id" "id" copy-key ;

extra/digraphs/digraphs.factor

@@ -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 )

extra/fries/fries.factor

@@ -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! ;

extra/gpu/framebuffers/framebuffers.factor

@@ -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 -- ) -- )
+:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
-    [ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ]
+    framebuffer color-attachments>>
-    [ swap depth-attachment>>   [ GL_DEPTH_ATTACHMENT   spin call ] [ drop ] if* ]
+    [| attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index
-    [ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline
+    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 -- )
 

extra/jamshred/tunnel/tunnel.factor

@@ -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.

extra/koszul/koszul.factor

@@ -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 )
+:: bigraded-ker/im-d ( basis -- seq )
-    dup length [
+    basis length iota [| z |
-        over first length [
+         basis first length iota [| u |
-            [ 2dup ] dip spin (bigraded-ker/im-d)
+            u z basis (bigraded-ker/im-d)
-        ] map 2nip
+        ] map
-    ] with 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 )
+:: bigraded-triples ( grid -- triples )
-    dup length [
+    grid length [| z |
-        over first length [
+        grid first length [| u |
-            [ 2dup ] dip spin bigraded-triple
+            u z grid bigraded-triple
-        ] map 2nip
+        ] map
-    ] with map ;
+    ] map ;
 
 : bigraded-laplacian ( u-generators z-generators quot -- seq )
     [ [ basis graded ] bi@ tensor bigraded-triples ] dip

extra/reports/noise/noise.factor

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

extra/set-n/set-n.factor

@@ -1,9 +1,9 @@
-USING: accessors assocs fry generalizations kernel math
+USING: accessors assocs fry generalizations kernel locals math
-namespaces parser sequences words ;
+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 ;

extra/space-invaders/space-invaders.factor

@@ -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 -- )
+:: set-bitmap-pixel ( bitmap point color -- )
-  #! 'color' is a {r g b}. Point is {x y}.
+    color point bitmap
-  [ bitmap-index ] dip ! color index array
+
-  [ [ first ] 2dip set-nth ] 3keep
+    point color :> index
-  [ [ second ] 2dip [ 1 + ] dip set-nth ] 3keep
+    color first  index     bitmap set-nth
-  [ third ] 2dip [ 2 + ] dip 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

extra/sudokus/sudokus.factor

@@ -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 ( -- ) [ [
         [

extra/tetris/game/game.factor

@@ -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 ;

extra/tokyo/assoc-functor/assoc-functor.factor

@@ -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 -- )
+M:: TYPE set-at ( value key db -- )
-    handle>> spin [ object>bytes dup length ] bi@ DBPUT drop ;
+    db handle>> key value [ object>bytes dup length ] bi@ DBPUT drop ;
 
-M: TYPE delete-at ( key db -- )
+M:: TYPE delete-at ( key db -- )
-    handle>> swap object>bytes dup length DBOUT drop ;
+    db handle>> key object>bytes dup length DBOUT drop ;
 
 M: TYPE clear-assoc ( db -- ) handle>> DBVANISH drop ;
 

extra/ui/gadgets/layout/layout.factor

@@ -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*
+: insertion-quot ( quot -- quot' )
-    templates get spin '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
+    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! ;

extra/units/units.factor

@@ -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* ;