From 14d00b3e8359d9c95abfe7bb538253df0e088cb8 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 29 Nov 2008 12:07:35 -0600
Subject: [PATCH 1/9] combinators.cleave.enhanced: Cleavers and spreaders which
accept words
---
.../cleave/enhanced/enhanced.factor | 31 +++++++++++++++++++
1 file changed, 31 insertions(+)
create mode 100644 extra/combinators/cleave/enhanced/enhanced.factor
diff --git a/extra/combinators/cleave/enhanced/enhanced.factor b/extra/combinators/cleave/enhanced/enhanced.factor
new file mode 100644
index 0000000000..b55979a791
--- /dev/null
+++ b/extra/combinators/cleave/enhanced/enhanced.factor
@@ -0,0 +1,31 @@
+
+USING: combinators.cleave fry kernel macros parser quotations ;
+
+IN: combinators.cleave.enhanced
+
+: \\
+ scan-word literalize parsed
+ scan-word literalize parsed ; parsing
+
+MACRO: bi ( p q -- quot )
+ [ >quot ] dip
+ >quot
+ '[ _ _ [ keep ] dip call ] ;
+
+MACRO: tri ( p q r -- quot )
+ [ >quot ] 2dip
+ [ >quot ] dip
+ >quot
+ '[ _ _ _ [ [ keep ] dip keep ] dip call ] ;
+
+MACRO: bi* ( p q -- quot )
+ [ >quot ] dip
+ >quot
+ '[ _ _ [ dip ] dip call ] ;
+
+MACRO: tri* ( p q r -- quot )
+ [ >quot ] 2dip
+ [ >quot ] dip
+ >quot
+ '[ _ _ _ [ [ 2dip ] dip dip ] dip call ] ;
+
From 536b412d2e308937e526d99251f4991b4d09c67a Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 29 Nov 2008 12:08:20 -0600
Subject: [PATCH 2/9] multi-method-syntax: Nicer specializer syntax to hold me
over till multi-methods are official
---
.../multi-method-syntax.factor | 23 +++++++++++++++++++
1 file changed, 23 insertions(+)
create mode 100644 extra/multi-method-syntax/multi-method-syntax.factor
diff --git a/extra/multi-method-syntax/multi-method-syntax.factor b/extra/multi-method-syntax/multi-method-syntax.factor
new file mode 100644
index 0000000000..9f05525f23
--- /dev/null
+++ b/extra/multi-method-syntax/multi-method-syntax.factor
@@ -0,0 +1,23 @@
+
+USING: accessors effects.parser kernel lexer multi-methods
+ parser sequences words ;
+
+IN: multi-method-syntax
+
+! A nicer specializer syntax to hold us over till multi-methods go in
+! officially.
+!
+! Use both 'multi-methods' and 'multi-method-syntax' in that order.
+
+: scan-specializer ( -- specializer )
+
+ scan drop ! eat opening parenthesis
+
+ ")" parse-effect in>> [ search ] map ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-specializer swap create-method-in ;
+
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
+
+: METHOD: (METHOD:) define ; parsing
\ No newline at end of file
From 1222fdf55b76c1880151dbb74e5f1cb03bf85870 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 29 Nov 2008 12:10:06 -0600
Subject: [PATCH 3/9] flatland: Library for two dimensional worlds
---
extra/flatland/flatland.factor | 178 +++++++++++++++++++++++++++++++++
1 file changed, 178 insertions(+)
create mode 100644 extra/flatland/flatland.factor
diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor
new file mode 100644
index 0000000000..a33da32908
--- /dev/null
+++ b/extra/flatland/flatland.factor
@@ -0,0 +1,178 @@
+
+USING: accessors arrays fry kernel math math.vectors sequences
+ math.intervals
+ multi-methods
+ combinators.cleave.enhanced
+ multi-method-syntax ;
+
+IN: flatland
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Two dimensional world protocol
+
+GENERIC: x ( obj -- x )
+GENERIC: y ( obj -- y )
+
+GENERIC: (x!) ( x obj -- )
+GENERIC: (y!) ( y obj -- )
+
+: x! ( obj x -- obj ) over (x!) ;
+: y! ( obj y -- obj ) over (y!) ;
+
+GENERIC: width ( obj -- width )
+GENERIC: height ( obj -- height )
+
+GENERIC: (width!) ( width obj -- )
+GENERIC: (height!) ( height obj -- )
+
+: width! ( obj width -- obj ) over (width!) ;
+: height! ( obj height -- obj ) over (width!) ;
+
+! Predicates on relative placement
+
+GENERIC: to-the-left-of? ( obj obj -- ? )
+GENERIC: to-the-right-of? ( obj obj -- ? )
+
+GENERIC: below? ( obj obj -- ? )
+GENERIC: above? ( obj obj -- ? )
+
+GENERIC: in-between-horizontally? ( obj obj -- ? )
+
+GENERIC: horizontal-interval ( obj -- interval )
+
+GENERIC: move-to ( obj obj -- )
+
+GENERIC: move-by ( obj delta -- )
+
+GENERIC: move-left-by ( obj obj -- )
+GENERIC: move-right-by ( obj obj -- )
+
+GENERIC: left ( obj -- left )
+GENERIC: right ( obj -- right )
+GENERIC: bottom ( obj -- bottom )
+GENERIC: top ( obj -- top )
+
+GENERIC: distance ( a b -- c )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some of the above methods work on two element sequences.
+! A two element sequence may represent a point in space or describe
+! width and height.
+
+METHOD: x ( sequence -- x ) first ;
+METHOD: y ( sequence -- y ) second ;
+
+METHOD: (x!) ( number sequence -- ) set-first ;
+METHOD: (y!) ( number sequence -- ) set-second ;
+
+METHOD: width ( sequence -- width ) first ;
+METHOD: height ( sequence -- height ) second ;
+
+: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
+: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
+
+METHOD: move-to ( sequence sequence -- ) [ x x! ] [ y y! ] bi drop ;
+METHOD: move-by ( sequence sequence -- ) dupd v+ [ x x! ] [ y y! ] bi drop ;
+
+METHOD: move-left-by ( sequence number -- ) '[ _ - ] changed-x ;
+METHOD: move-right-by ( sequence number -- ) '[ _ + ] changed-x ;
+
+! METHOD: move-left-by ( sequence number -- ) neg 0 2array move-by ;
+! METHOD: move-right-by ( sequence number -- ) 0 2array move-by ;
+
+! METHOD:: move-left-by ( SEQ:sequence X:number -- )
+! SEQ { X 0 } { -1 0 } v* move-by ;
+
+METHOD: distance ( sequence sequence -- dist ) v- norm ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with a position
+
+TUPLE: <pos> pos ;
+
+METHOD: x ( <pos> -- x ) pos>> first ;
+METHOD: y ( <pos> -- y ) pos>> second ;
+
+METHOD: (x!) ( number <pos> -- ) pos>> set-first ;
+METHOD: (y!) ( number <pos> -- ) pos>> set-second ;
+
+METHOD: to-the-left-of? ( <pos> number -- ? ) [ x ] dip < ;
+METHOD: to-the-right-of? ( <pos> number -- ? ) [ x ] dip > ;
+
+METHOD: move-left-by ( <pos> number -- ) [ pos>> ] dip move-left-by ;
+METHOD: move-right-by ( <pos> number -- ) [ pos>> ] dip move-right-by ;
+
+METHOD: above? ( <pos> number -- ? ) [ y ] dip > ;
+METHOD: below? ( <pos> number -- ? ) [ y ] dip < ;
+
+METHOD: move-by ( <pos> sequence -- ) '[ _ v+ ] change-pos drop ;
+
+METHOD: distance ( <pos> <pos> -- dist ) [ pos>> ] bi@ distance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with velocity. It inherits from <pos>. Hey, if
+! it's moving it has a position right? Unless it's some alternate universe...
+
+TUPLE: <vel> < <pos> vel ;
+
+: moving-up? ( obj -- ? ) vel>> y 0 > ;
+: moving-down? ( obj -- ? ) vel>> y 0 < ;
+
+: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
+: move-for ( vel time -- ) dupd step-size move-by ;
+
+: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! The 'pos' slot indicates the lower left hand corner of the
+! rectangle. The 'dim' is holds the width and height.
+
+TUPLE: <rectangle> < <pos> dim ;
+
+METHOD: width ( <rectangle> -- width ) dim>> first ;
+METHOD: height ( <rectangle> -- height ) dim>> second ;
+
+METHOD: left ( <rectangle> -- x ) x ;
+METHOD: right ( <rectangle> -- x ) \\ x width bi + ;
+METHOD: bottom ( <rectangle> -- y ) y ;
+METHOD: top ( <rectangle> -- y ) \\ y height bi + ;
+
+: bottom-left ( rectangle -- pos ) pos>> ;
+
+: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
+: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
+
+: center ( rectangle -- seq ) \\ center-x center-y bi 2array ;
+
+METHOD: to-the-left-of? ( <pos> <rectangle> -- ? ) \\ x left bi* < ;
+METHOD: to-the-right-of? ( <pos> <rectangle> -- ? ) \\ x right bi* > ;
+
+METHOD: below? ( <pos> <rectangle> -- ? ) \\ y bottom bi* < ;
+METHOD: above? ( <pos> <rectangle> -- ? ) \\ y top bi* > ;
+
+METHOD: horizontal-interval ( <rectangle> -- interval )
+ \\ left right bi [a,b] ;
+
+METHOD: in-between-horizontally? ( <pos> <rectangle> -- ? )
+ \\ x horizontal-interval bi* interval-contains? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <extent> left right bottom top ;
+
+METHOD: left ( <extent> -- left ) left>> ;
+METHOD: right ( <extent> -- right ) right>> ;
+METHOD: bottom ( <extent> -- bottom ) bottom>> ;
+METHOD: top ( <extent> -- top ) top>> ;
+
+METHOD: width ( <extent> -- width ) \\ right>> left>> bi - ;
+METHOD: height ( <extent> -- height ) \\ top>> bottom>> bi - ;
+
+! METHOD: to-extent ( <rectangle> -- <extent> )
+! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
+
From d9f8ecbbe5389c3b3434838e150e3df536ee79cf Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 29 Nov 2008 12:10:55 -0600
Subject: [PATCH 4/9] pong: pong-o-rama
---
extra/pong/pong.factor | 195 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 195 insertions(+)
create mode 100644 extra/pong/pong.factor
diff --git a/extra/pong/pong.factor b/extra/pong/pong.factor
new file mode 100644
index 0000000000..befb64a7a7
--- /dev/null
+++ b/extra/pong/pong.factor
@@ -0,0 +1,195 @@
+
+USING: kernel accessors locals math math.intervals math.order
+ namespaces sequences threads
+ ui
+ ui.gadgets
+ ui.gestures
+ ui.render
+ calendar
+ multi-methods
+ multi-method-syntax
+ combinators.short-circuit.smart
+ combinators.cleave.enhanced
+ processing.shapes
+ flatland ;
+
+IN: pong
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clamp-to-interval ( x interval -- x )
+ [ from>> first max ] [ to>> first min ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <play-field> < <rectangle> ;
+TUPLE: <paddle> < <rectangle> ;
+
+TUPLE: <computer> < <paddle> { speed initial: 10 } ;
+
+: computer-move-left ( computer -- ) dup speed>> move-left-by ;
+: computer-move-right ( computer -- ) dup speed>> move-right-by ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <ball> < <vel>
+ { diameter initial: 20 }
+ { bounciness initial: 1.2 }
+ { max-speed initial: 10 } ;
+
+: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
+: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
+
+: in-bounds? ( ball field -- ? )
+ {
+ [ above-lower-bound? ]
+ [ below-upper-bound? ]
+ } && ;
+
+:: bounce-change-vertical-velocity ( BALL -- )
+
+ BALL vel>> y neg
+ BALL bounciness>> *
+
+ BALL max-speed>> min
+
+ BALL vel>> (y!) ;
+
+:: bounce-off-paddle ( BALL PADDLE -- )
+
+ BALL bounce-change-vertical-velocity
+
+ BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
+
+ PADDLE top BALL pos>> (y!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-x ( -- x ) hand-loc get first ;
+
+:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
+
+ PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
+
+:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
+
+ mouse-x
+
+ PADDLE PLAY-FIELD valid-paddle-interval
+
+ clamp-to-interval
+
+ PADDLE pos>> (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Protocol for drawing PONG objects
+
+GENERIC: draw ( obj -- )
+
+METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
+METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
+ ! by multi-methods
+
+TUPLE: <pong> < gadget draw closed ;
+
+M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
+M: <pong> draw-gadget* ( <pong> -- ) draw>> call ;
+M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-draw-closure ( -- closure )
+
+ ! Establish some bindings
+
+ [let | PLAY-FIELD [ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } ]
+ BALL [ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } ]
+
+ PLAYER [ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } ]
+ COMPUTER [ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } ] |
+
+ ! Define some internal words in terms of those bindings ...
+
+ [wlet | align-player-with-mouse [ ( -- )
+ PLAYER PLAY-FIELD align-paddle-with-mouse ]
+
+ move-ball [ ( -- ) BALL 1 move-for ]
+
+ player-blocked-ball? [ ( -- ? )
+ BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
+
+ computer-blocked-ball? [ ( -- ? )
+ BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
+
+ bounce-off-wall? [ ( -- ? )
+ BALL PLAY-FIELD in-between-horizontally? not ] |
+
+ ! Note, we're returning a quotation.
+ ! The quotation closes over the bindings established by the 'let'.
+ ! Thus the name of the word 'make-draw-closure'.
+ ! This closure is intended to be placed in the 'draw' slot of a
+ ! <pong> gadget.
+
+ [
+
+ BALL PLAY-FIELD in-bounds?
+ [
+ align-player-with-mouse
+
+ move-ball
+
+ ! computer reaction
+
+ BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
+ BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+
+ ! check if ball bounced off something
+
+ player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
+ computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
+ bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
+
+ ! draw the objects
+
+ COMPUTER draw
+ PLAYER draw
+ BALL draw
+
+ ]
+ when
+
+ ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
+ ! The stack effects in the wlet expression throw
+ ! off the effect for the whole word, so we reset
+ ! it to the correct one here.
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: pong-loop-step ( PONG -- ? )
+ PONG closed>>
+ [ f ]
+ [ PONG relayout-1 25 milliseconds sleep t ]
+ if ;
+
+:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: play-pong ( -- )
+
+ <pong> new-gadget
+ make-draw-closure >>draw
+ dup "PONG" open-window
+
+ start-pong-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: play-pong-main ( -- ) [ play-pong ] with-ui ;
+
+MAIN: play-pong-main
\ No newline at end of file
From 1ea8d6c770daffa753793a7b73d98df2bee113d3 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 29 Nov 2008 12:11:49 -0600
Subject: [PATCH 5/9] boids: Use flatland
---
extra/boids/boids.factor | 7 +++----
1 file changed, 3 insertions(+), 4 deletions(-)
diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor
index eeebe1c12d..1d5074693a 100644
--- a/extra/boids/boids.factor
+++ b/extra/boids/boids.factor
@@ -6,18 +6,17 @@ USING: kernel namespaces
math.order
math.vectors
math.trig
- math.physics.pos
- math.physics.vel
combinators arrays sequences random vars
combinators.lib
combinators.short-circuit
- accessors ;
+ accessors
+ flatland ;
IN: boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: boid < vel ;
+TUPLE: boid < <vel> ;
C: <boid> boid
From 09a431f0b34aeee68c53c4365a32af75216f957b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 29 Nov 2008 20:15:04 -0600
Subject: [PATCH 6/9] dlist>seq now preserves f entries as reported by leifkb
---
basis/dlists/dlists-tests.factor | 4 ++++
basis/dlists/dlists.factor | 2 +-
2 files changed, 5 insertions(+), 1 deletion(-)
diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor
index 6df3e306dd..084aa0ac89 100644
--- a/basis/dlists/dlists-tests.factor
+++ b/basis/dlists/dlists-tests.factor
@@ -75,3 +75,7 @@ IN: dlists.tests
dup clone 3 over push-back
[ dlist>seq ] bi@
] unit-test
+
+[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
+
+[ V{ } ] [ <dlist> dlist>seq ] unit-test
diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index bd4e7c46e6..d8b78558d4 100644
--- a/basis/dlists/dlists.factor
+++ b/basis/dlists/dlists.factor
@@ -154,7 +154,7 @@ M: dlist clear-deque ( dlist -- )
[ obj>> ] prepose dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
- [ ] pusher [ dlist-each ] dip ;
+ [ drop t ] pusher [ dlist-each ] dip ;
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
From 1a50bcce759caec22b91ebc56c287cfc05379047 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 29 Nov 2008 20:17:16 -0600
Subject: [PATCH 7/9] dlist>seq was defined in dlists and linked-assocs
---
basis/linked-assocs/linked-assocs.factor | 3 ---
1 file changed, 3 deletions(-)
diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
index 7330ac1a56..f9f84fbbae 100644
--- a/basis/linked-assocs/linked-assocs.factor
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -28,9 +28,6 @@ M: linked-assoc set-at
[ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
assoc>> set-at ;
-: dlist>seq ( dlist -- seq )
- [ ] pusher [ dlist-each ] dip ;
-
M: linked-assoc >alist
dlist>> dlist>seq ;
From bc14b8c7c85c480207ca0f3e84c5b57259b27f5b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 29 Nov 2008 20:19:40 -0600
Subject: [PATCH 8/9] fix a netbsd struct definition and some >r r> usage
---
basis/unix/process/process.factor | 2 +-
basis/unix/statfs/netbsd/netbsd.factor | 4 ++--
basis/unix/unix.factor | 8 ++++----
3 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor
index 030f0977e2..175425f948 100644
--- a/basis/unix/process/process.factor
+++ b/basis/unix/process/process.factor
@@ -33,7 +33,7 @@ FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
[ first ] [ ] bi exec-with-path ;
: exec-args-with-env ( seq seq -- int )
- >r [ first ] [ ] bi r> exec-with-env ;
+ [ [ first ] [ ] bi ] dip exec-with-env ;
: with-fork ( child parent -- )
[ [ fork-process dup zero? ] dip [ drop ] prepose ] dip
diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor
index 56c632edb4..ad7c161713 100644
--- a/basis/unix/statfs/netbsd/netbsd.factor
+++ b/basis/unix/statfs/netbsd/netbsd.factor
@@ -31,8 +31,8 @@ C-STRUCT: statvfs
{ "uid_t" "f_owner" }
{ { "uint32_t" 4 } "f_spare" }
{ { "char" _VFS_NAMELEN } "f_fstypename" }
- { { "char" _VFS_NAMELEN } "f_mntonname" }
- { { "char" _VFS_NAMELEN } "f_mntfromname" } ;
+ { { "char" _VFS_MNAMELEN } "f_mntonname" }
+ { { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
FUNCTION: int statvfs ( char* path, statvfs *buf ) ;
diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor
index ca8a7a2e60..d917425bf9 100644
--- a/basis/unix/unix.factor
+++ b/basis/unix/unix.factor
@@ -198,10 +198,10 @@ FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
: PATH_MAX 1024 ; inline
: read-symbolic-link ( path -- path )
- PATH_MAX <byte-array> dup >r
- PATH_MAX
- [ readlink ] unix-system-call
- r> swap head-slice >string ;
+ PATH_MAX <byte-array> dup [
+ PATH_MAX
+ [ readlink ] unix-system-call
+ ] dip swap head-slice >string ;
FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
From 6395204720f99c022009a3fcb3797151183fd9a0 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 29 Nov 2008 20:25:27 -0600
Subject: [PATCH 9/9] boids: Use 'math.ranges'
---
extra/boids/boids.factor | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor
index 1d5074693a..857abcf5d3 100644
--- a/extra/boids/boids.factor
+++ b/extra/boids/boids.factor
@@ -6,6 +6,7 @@ USING: kernel namespaces
math.order
math.vectors
math.trig
+ math.ranges
combinators arrays sequences random vars
combinators.lib
combinators.short-circuit
@@ -61,11 +62,9 @@ VAR: separation-radius
! random-boid and random-boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: random-range ( a b -- n ) 1+ over - random + ;
-
: random-pos ( -- pos ) world-size> [ random ] map ;
-: random-vel ( -- vel ) 2 [ drop -10 10 random-range ] map ;
+: random-vel ( -- vel ) 2 [ drop -10 10 [a,b] random ] map ;
: random-boid ( -- boid ) random-pos random-vel <boid> ;