eliminate most spins from extra

diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor
index 31a4b75eb2e985bddb92e7b55d992bd2671c0f92..a379a03828a227d7269b5befdda8e5ce050e4b22 100644 (file)
--- a/extra/bank/bank.factor
+++ b/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 ;

diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor
index 3018fa7a2469d400d9ffd5930bea8b5fa646778f..77f041835b1252ff32dc41c19f5ce81bae4e71e2 100644 (file)
--- a/extra/c/preprocessor/preprocessor.factor
+++ b/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 -- )
-    [ 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 ;

diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor
index da71acb07408a94b9446bfcaadaa8cca948ded10..ed5dd1268fa9042a445a176879a9e454a6dbad04 100644 (file)
--- a/extra/couchdb/couchdb.factor
+++ b/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
-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 ;

diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor
index 2b3379861f3c3c7752bbd892df61eea2a035e250..ccbe90fb3c40ddbecd2d600605b2c37e3dc8f0d8 100755 (executable)
--- a/extra/digraphs/digraphs.factor
+++ b/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 )

diff --git a/extra/fries/fries.factor b/extra/fries/fries.factor
index 133e8913ddf684ffd83e9abedf7241684a6c0d8c..3f970a86bfa91554c10bb2f823e9f7c64f6a9e48 100644 (file)
--- a/extra/fries/fries.factor
+++ b/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! ;

diff --git a/extra/gpu/framebuffers/framebuffers.factor b/extra/gpu/framebuffers/framebuffers.factor
index efd71782d01550e353d9c22e94f0b27231d94a2a..bea72961e4f6729f074e01a3294af398823c8f90 100755 (executable)
--- a/extra/gpu/framebuffers/framebuffers.factor
+++ b/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 -- ) -- )
-    [ [ 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 -- )
 

diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor
index f7eac9d02cab343f611abc49532e3c237adcbb8f..e7285dcbbc56eef78ea9c8d5cfd2ef64d9084b0f 100644 (file)
--- a/extra/jamshred/tunnel/tunnel.factor
+++ b/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.

diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor
index 59efec1c02302124c896aa0956fc71e538470e8b..3e3d67195e2f5857616c0e7513439f68368fd3a8 100755 (executable)
--- a/extra/koszul/koszul.factor
+++ b/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 )
-    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

diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index 9eb2804b4298c7f89aaba649211618e83fc0352b..69ac897e3454a564c21710b703bd39e8a048bb50 100755 (executable)
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -54,7 +54,6 @@ IN: reports.noise
         { over 2 }\r
         { pick 4 }\r
         { rot 3 }\r
-        { spin 3 }\r
         { swap 1 }\r
         { swapd 3 }\r
         { tuck 2 }\r

diff --git a/extra/set-n/set-n.factor b/extra/set-n/set-n.factor
index 04731b0e27d6210833b4c500a029090ba7d2a4a1..80d8bf224695914714862a7264ed4d225ff0cef7 100644 (file)
--- a/extra/set-n/set-n.factor
+++ b/extra/set-n/set-n.factor
@@ -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 ;
\ No newline at end of file
+SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ;

diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor
index 07b5608a767159e16f5ecb69d83584033450cf25..db6ed7ed04492ab23e35ec6711605d1e7d34b499 100755 (executable)
--- a/extra/space-invaders/space-invaders.factor
+++ b/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 -- )
-  #! '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

diff --git a/extra/sudokus/sudokus.factor b/extra/sudokus/sudokus.factor
index ff20f1520469107d7e4b912eec893c132dc49a2b..c7bc6944fb9eb6812edcf08438fcad9dbfc3eb04 100644 (file)
--- a/extra/sudokus/sudokus.factor
+++ 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 ( -- ) [ [
         [

diff --git a/extra/tetris/game/game.factor b/extra/tetris/game/game.factor
index e1b5867f64ed684ae5095036171bd144b60da824..c9e235ff7953ef71350d8b78cf2e4608d842c39d 100644 (file)
--- a/extra/tetris/game/game.factor
+++ b/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 ;

diff --git a/extra/tokyo/assoc-functor/assoc-functor.factor b/extra/tokyo/assoc-functor/assoc-functor.factor
index 122e6133874fbdbb0e8bbbad8b21e00043620d74..bb2b1d8b6d8be5b8c7c6606f72b00c3b3e67423f 100644 (file)
--- a/extra/tokyo/assoc-functor/assoc-functor.factor
+++ b/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 -- )
-    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 ;
 

diff --git a/extra/ui/gadgets/layout/layout.factor b/extra/ui/gadgets/layout/layout.factor
index 7bdde95d60e8fd4499be1a6e2b0ee3d492e15e95..c287b9a0598ed33f4525c0b509ca30ca8ec8be59 100644 (file)
--- a/extra/ui/gadgets/layout/layout.factor
+++ b/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*
-    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! ;

diff --git a/extra/units/units.factor b/extra/units/units.factor
index b8e3f45a16eca370ff3ed7c63f1689c5dcd0252f..a293d79f78cc3c962e7cbc85e508bb3699da35f5 100755 (executable)
--- a/extra/units/units.factor
+++ b/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* ;