From 52c5b53e27963a3ce443c613be22072edfd1ffb7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 30 Nov 2008 22:21:37 -0600
Subject: [PATCH 1/7] Refactoring usages of >r, r>, -rot, rot
---
basis/alien/c-types/c-types.factor | 4 +-
basis/alien/structs/structs-tests.factor | 2 +-
basis/cocoa/dialogs/dialogs.factor | 6 +--
basis/cocoa/messages/messages.factor | 2 +-
basis/cocoa/windows/windows.factor | 3 +-
.../core-foundation/fsevents/fsevents.factor | 27 +++++-------
basis/delegate/delegate.factor | 2 +-
basis/inspector/inspector.factor | 6 +--
basis/io/unix/select/select.factor | 2 +-
basis/io/unix/sockets/sockets.factor | 2 +-
basis/math/complex/complex.factor | 20 ++++-----
basis/math/functions/functions.factor | 44 +++++++++----------
basis/math/ranges/ranges.factor | 4 +-
core/assocs/assocs.factor | 4 +-
core/classes/intersection/intersection.factor | 2 +-
core/classes/tuple/tuple.factor | 4 +-
core/words/words.factor | 2 +-
17 files changed, 67 insertions(+), 69 deletions(-)
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 7a20632ca4..de8d36521e 100644
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -201,10 +201,10 @@ M: byte-array byte-length length ;
1 swap malloc-array ; inline
: malloc-byte-array ( byte-array -- alien )
- dup length dup malloc [ -rot memcpy ] keep ;
+ dup length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
- dup <byte-array> [ -rot memcpy ] keep ;
+ [ nip <byte-array> dup ] 2keep memcpy ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor
index 8c7d9f9b29..ec0c01c2e7 100644
--- a/basis/alien/structs/structs-tests.factor
+++ b/basis/alien/structs/structs-tests.factor
@@ -38,7 +38,7 @@ C-UNION: barx
[ 120 ] [ "barx" heap-size ] unit-test
"help" vocab [
- "help" "help" lookup "help" set
+ "print-topic" "help" lookup "help" set
[ ] [ \ foox-x "help" get execute ] unit-test
[ ] [ \ set-foox-x "help" get execute ] unit-test
] when
diff --git a/basis/cocoa/dialogs/dialogs.factor b/basis/cocoa/dialogs/dialogs.factor
index 662b4a7bae..2b01c5d751 100644
--- a/basis/cocoa/dialogs/dialogs.factor
+++ b/basis/cocoa/dialogs/dialogs.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cocoa cocoa.messages cocoa.classes
cocoa.application sequences splitting core-foundation ;
@@ -29,6 +29,6 @@ IN: cocoa.dialogs
"/" split1-last [ <NSString> ] bi@ ;
: save-panel ( path -- paths )
- <NSSavePanel> dup
- rot split-path -> runModalForDirectory:file: NSOKButton =
+ [ <NSSavePanel> dup ] dip
+ split-path -> runModalForDirectory:file: NSOKButton =
[ -> filename CF>string ] [ drop f ] if ;
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 4dedd8455a..5bcd6d6f60 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -160,7 +160,7 @@ objc>alien-types get [ swap ] assoc-map
assoc-union alien>objc-types set-global
: objc-struct-type ( i string -- ctype )
- 2dup CHAR: = -rot index-from swap subseq
+ [ CHAR: = ] 2keep index-from swap subseq
dup c-types get key? [
"Warning: no such C type: " write dup print
drop "void*"
diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor
index dd2d1bfd41..3a53a1cc3c 100644
--- a/basis/cocoa/windows/windows.factor
+++ b/basis/cocoa/windows/windows.factor
@@ -34,5 +34,6 @@ IN: cocoa.windows
dup 0 -> setReleasedWhenClosed: ;
: window-content-rect ( window -- rect )
- NSWindow over -> frame rot -> styleMask
+ [ NSWindow ] dip
+ [ -> frame ] [ -> styleMask ] bi
-> contentRectForFrameRect:styleMask: ;
diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor
index 6bec4b23c0..80678ec3da 100644
--- a/basis/core-foundation/fsevents/fsevents.factor
+++ b/basis/core-foundation/fsevents/fsevents.factor
@@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
continuations combinators core-foundation
core-foundation.run-loop core-foundation.run-loop.thread
-io.encodings.utf8 destructors ;
+io.encodings.utf8 destructors locals arrays ;
IN: core-foundation.fsevents
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
@@ -105,15 +105,14 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef
"FSEventStreamContext" <c-object>
[ set-FSEventStreamContext-info ] keep ;
-: <FSEventStream> ( callback info paths latency flags -- event-stream )
- >r >r >r >r >r
+:: <FSEventStream> ( callback info paths latency flags -- event-stream )
f ! allocator
- r> ! callback
- r> make-FSEventStreamContext
- r> <CFStringArray> ! paths
+ callback
+ info make-FSEventStreamContext
+ paths <CFStringArray>
FSEventStreamEventIdSinceNow ! sinceWhen
- r> ! latency
- r> ! flags
+ latency
+ flags
FSEventStreamCreate ;
: kCFRunLoopCommonModes ( -- string )
@@ -161,13 +160,11 @@ SYMBOL: event-stream-callbacks
: remove-event-source-callback ( id -- )
event-stream-callbacks get delete-at ;
-: >event-triple ( n eventPaths eventFlags eventIds -- triple )
- [
- >r >r >r dup dup
- r> void*-nth utf8 alien>string ,
- r> int-nth ,
- r> longlong-nth ,
- ] { } make ;
+:: >event-triple ( n eventPaths eventFlags eventIds -- triple )
+ n eventPaths void*-nth utf8 alien>string
+ n eventFlags int-nth
+ n eventIds longlong-nth
+ 3array ;
: master-event-source-callback ( -- alien )
"void"
diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor
index 3a7cecb800..e7ea370b8d 100644
--- a/basis/delegate/delegate.factor
+++ b/basis/delegate/delegate.factor
@@ -36,7 +36,7 @@ M: tuple-class group-words
: define-consult ( group class quot -- )
[ register-protocol ]
- [ rot group-words -rot [ consult-method ] 2curry each ]
+ [ [ group-words ] 2dip [ consult-method ] 2curry each ]
3bi ;
: CONSULT:
diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor
index 7b451d5266..b47426f5bb 100644
--- a/basis/inspector/inspector.factor
+++ b/basis/inspector/inspector.factor
@@ -49,10 +49,8 @@ SYMBOL: +editable+
] [ keys ] if ;
: describe* ( obj mirror keys -- )
- rot summary.
- [
- drop
- ] [
+ [ summary. ] 2dip
+ [ drop ] [
dup enum? [ +sequence+ on ] when
standard-table-style [
swap [ -rot describe-row ] curry each-index
diff --git a/basis/io/unix/select/select.factor b/basis/io/unix/select/select.factor
index 530dfe7ab3..1dd1d51e87 100644
--- a/basis/io/unix/select/select.factor
+++ b/basis/io/unix/select/select.factor
@@ -19,7 +19,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
FD_SETSIZE 8 * <bit-array> >>write-fdset ;
: clear-nth ( n seq -- ? )
- [ nth ] [ f -rot set-nth ] 2bi ;
+ [ nth ] [ [ f ] 2dip set-nth ] 2bi ;
:: check-fd ( fd fdset mx quot -- )
fd munge fdset clear-nth [ fd mx quot call ] when ; inline
diff --git a/basis/io/unix/sockets/sockets.factor b/basis/io/unix/sockets/sockets.factor
index 8f9ff4f066..a98432b84d 100644
--- a/basis/io/unix/sockets/sockets.factor
+++ b/basis/io/unix/sockets/sockets.factor
@@ -114,7 +114,7 @@ SYMBOL: receive-buffer
] call ;
M: unix (receive) ( datagram -- packet sockaddr )
- dup do-receive dup [ rot drop ] [
+ dup do-receive dup [ [ drop ] 2dip ] [
2drop [ +input+ wait-for-port ] [ (receive) ] bi
] if ;
diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor
index acc8a9d6d6..c228684e32 100644
--- a/basis/math/complex/complex.factor
+++ b/basis/math/complex/complex.factor
@@ -14,8 +14,8 @@ M: complex imaginary-part imaginary>> ;
M: complex absq >rect [ sq ] bi@ + ;
: 2>rect ( x y -- xr yr xi yi )
- [ [ real-part ] bi@ ] 2keep
- [ imaginary-part ] bi@ ; inline
+ [ [ real-part ] bi@ ]
+ [ [ imaginary-part ] bi@ ] 2bi ; inline
M: complex hashcode*
nip >rect [ hashcode ] bi@ bitxor ;
@@ -28,21 +28,21 @@ M: complex equal?
M: complex number=
2>rect number= [ number= ] [ 2drop f ] if ;
-: *re ( x y -- xr*yr xi*ri ) 2>rect * >r * r> ; inline
-: *im ( x y -- xi*yr xr*yi ) 2>rect >r * swap r> * ; inline
+: *re ( x y -- xr*yr xi*ri ) 2>rect [ * ] 2bi@ ; inline
+: *im ( x y -- xi*yr xr*yi ) 2>rect [ * swap ] dip * ; inline
-M: complex + 2>rect + >r + r> (rect>) ;
-M: complex - 2>rect - >r - r> (rect>) ;
-M: complex * 2dup *re - -rot *im + (rect>) ;
+M: complex + 2>rect [ + ] 2bi@ (rect>) ;
+M: complex - 2>rect [ - ] 2bi@ (rect>) ;
+M: complex * [ *re - ] [ *im + ] 2bi (rect>) ;
: complex/ ( x y -- r i m )
- dup absq >r 2dup *re + -rot *im - r> ; inline
+ [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
-M: complex / complex/ tuck / >r / r> (rect>) ;
+M: complex / complex/ tuck [ / ] 2bi@ (rect>) ;
M: complex abs absq >float fsqrt ;
-M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ;
+M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ;
IN: syntax
diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index 1cea0a74dd..8411baf94c 100644
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -92,16 +92,6 @@ PRIVATE>
: 0^ ( x -- z )
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
-PRIVATE>
-
-: ^ ( x y -- z )
- {
- { [ over zero? ] [ nip 0^ ] }
- { [ dup integer? ] [ integer^ ] }
- { [ 2dup real^? ] [ fpow ] }
- [ ^complex ]
- } cond ; inline
-
: (^mod) ( n x y -- z )
1 swap [
[ dupd * pick mod ] when [ sq over mod ] dip
@@ -114,6 +104,16 @@ PRIVATE>
swap [ /mod [ over * swapd - ] dip ] keep (gcd)
] if ;
+PRIVATE>
+
+: ^ ( x y -- z )
+ {
+ { [ over zero? ] [ nip 0^ ] }
+ { [ dup integer? ] [ integer^ ] }
+ { [ 2dup real^? ] [ fpow ] }
+ [ ^complex ]
+ } cond ; inline
+
: gcd ( x y -- a d )
[ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable
@@ -177,9 +177,9 @@ M: complex log >polar swap flog swap rect> ;
GENERIC: cos ( x -- y ) foldable
M: complex cos
- >float-rect 2dup
- fcosh swap fcos * -rot
- fsinh swap fsin neg * rect> ;
+ >float-rect
+ [ [ fcos ] [ fcosh ] bi* * ]
+ [ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
M: real cos fcos ;
@@ -188,9 +188,9 @@ M: real cos fcos ;
GENERIC: cosh ( x -- y ) foldable
M: complex cosh
- >float-rect 2dup
- fcos swap fcosh * -rot
- fsin swap fsinh * rect> ;
+ >float-rect
+ [ [ fcosh ] [ fcos ] bi* * ]
+ [ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
M: real cosh fcosh ;
@@ -199,9 +199,9 @@ M: real cosh fcosh ;
GENERIC: sin ( x -- y ) foldable
M: complex sin
- >float-rect 2dup
- fcosh swap fsin * -rot
- fsinh swap fcos * rect> ;
+ >float-rect
+ [ [ fsin ] [ fcosh ] bi* * ]
+ [ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
M: real sin fsin ;
@@ -210,9 +210,9 @@ M: real sin fsin ;
GENERIC: sinh ( x -- y ) foldable
M: complex sinh
- >float-rect 2dup
- fcos swap fsinh * -rot
- fsin swap fcosh * rect> ;
+ >float-rect
+ [ [ fsinh ] [ fcos ] bi* * ]
+ [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
M: real sinh fsinh ;
diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor
index 388d117959..f7b3b37e25 100644
--- a/basis/math/ranges/ranges.factor
+++ b/basis/math/ranges/ranges.factor
@@ -22,9 +22,9 @@ INSTANCE: range immutable-sequence
: twiddle 2dup > -1 1 ? ; inline
-: (a, dup roll + -rot ; inline
+: (a, dup [ + ] curry 2dip ; inline
-: ,b) dup neg rot + swap ; inline
+: ,b) dup [ - ] curry dip ; inline
: [a,b] ( a b -- range ) twiddle <range> ; inline
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 953cc38c56..a0d16084b1 100644
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -110,8 +110,8 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
swap [ swapd set-at ] curry assoc-each ;
: assoc-union ( assoc1 assoc2 -- union )
- 2dup [ assoc-size ] bi@ + pick new-assoc
- [ rot update ] keep [ swap update ] keep ;
+ [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
+ [ dupd update ] bi@ ;
: assoc-combine ( seq -- union )
H{ } clone [ dupd update ] reduce ;
diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor
index 55831fcdb4..fffb172204 100644
--- a/core/classes/intersection/intersection.factor
+++ b/core/classes/intersection/intersection.factor
@@ -23,7 +23,7 @@ PREDICATE: intersection-class < class
M: intersection-class update-class define-intersection-predicate ;
: define-intersection-class ( class participants -- )
- [ f f rot intersection-class define-class ]
+ [ [ f f ] dip intersection-class define-class ]
[ drop update-classes ]
2bi ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index b6b277a32f..6f8021f733 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -248,7 +248,9 @@ M: tuple-class update-class
3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? )
- rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
+ [ over ] dip
+ [ [ superclass ] dip = ]
+ [ [ "slots" word-prop ] dip = ] 2bi* and ;
: valid-superclass? ( class -- ? )
[ tuple-class? ] [ tuple eq? ] bi or ;
diff --git a/core/words/words.factor b/core/words/words.factor
index 929161c5d6..618e04ffb4 100644
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -221,7 +221,7 @@ M: word subwords drop f ;
"( gensym )" f <word> ;
: define-temp ( quot -- word )
- gensym dup rot define ;
+ [ gensym dup ] dip define ;
: reveal ( word -- )
dup [ name>> ] [ vocabulary>> ] bi dup vocab-words
From f75a52474b4505a031b091a40907ada4e76d2648 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 1 Dec 2008 13:15:47 -0600
Subject: [PATCH 2/7] flatland: minor changes
---
extra/flatland/flatland.factor | 42 ++++++++++++++++++++++++++++++++++
1 file changed, 42 insertions(+)
diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor
index a33da32908..c98c5a6c57 100644
--- a/extra/flatland/flatland.factor
+++ b/extra/flatland/flatland.factor
@@ -176,3 +176,45 @@ METHOD: height ( <extent> -- height ) \\ top>> bottom>> bi - ;
! METHOD: to-extent ( <rectangle> -- <extent> )
! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: to-the-left-of? ( sequence <rectangle> -- ? ) \\ x left bi* < ;
+METHOD: to-the-right-of? ( sequence <rectangle> -- ? ) \\ x right bi* > ;
+
+METHOD: below? ( sequence <rectangle> -- ? ) \\ y bottom bi* < ;
+METHOD: above? ( sequence <rectangle> -- ? ) \\ y top bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some support for the' 'rect' class from math.geometry.rect'
+
+! METHOD: width ( rect -- width ) dim>> first ;
+! METHOD: height ( rect -- height ) dim>> second ;
+
+! METHOD: left ( rect -- left ) loc>> x
+! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
+
+! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
+! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: locals combinators ;
+
+:: wrap ( POINT RECT -- POINT )
+
+ {
+ { [ POINT RECT to-the-left-of? ] [ RECT right ] }
+ { [ POINT RECT to-the-right-of? ] [ RECT left ] }
+ { [ t ] [ POINT x ] }
+ }
+ cond
+
+ {
+ { [ POINT RECT below? ] [ RECT top ] }
+ { [ POINT RECT above? ] [ RECT bottom ] }
+ { [ t ] [ POINT y ] }
+ }
+ cond
+
+ 2array ;
From d9b4402ae212da65776d172d8990ce52fb7d003f Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 1 Dec 2008 13:16:30 -0600
Subject: [PATCH 3/7] boids.ui: removed
---
extra/boids/ui/ui.factor | 176 ---------------------------------------
1 file changed, 176 deletions(-)
delete mode 100755 extra/boids/ui/ui.factor
diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor
deleted file mode 100755
index ddb25ccd8d..0000000000
--- a/extra/boids/ui/ui.factor
+++ /dev/null
@@ -1,176 +0,0 @@
-
-USING: combinators.short-circuit kernel namespaces
- math
- math.trig
- math.functions
- math.vectors
- math.parser
- hashtables sequences threads
- colors
- opengl
- opengl.gl
- ui
- ui.gadgets
- ui.gadgets.handler
- ui.gadgets.slate
- ui.gadgets.theme
- ui.gadgets.frames
- ui.gadgets.labels
- ui.gadgets.buttons
- ui.gadgets.packs
- ui.gadgets.grids
- ui.gestures
- assocs.lib vars rewrite-closures boids accessors
- math.geometry.rect
- newfx
- processing.shapes ;
-
-IN: boids.ui
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! draw-boid
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-boid ( boid -- )
- glPushMatrix
- dup pos>> gl-translate-2d
- vel>> first2 rect> arg rad>deg 0 0 1 glRotated
- { { 0 5 } { 0 -5 } { 20 0 } } triangle
- fill-mode
- glPopMatrix ;
-
-: draw-boids ( -- ) boids> [ draw-boid ] each ;
-
-: boid-color ( -- color ) T{ rgba f 1.0 0 0 0.3 } ;
-
-: display ( -- )
- boid-color >fill-color
- draw-boids ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: slate
-
-VAR: loop
-
-: run ( -- )
- slate> rect-dim >world-size
- iterate-boids
- slate> relayout-1
- yield
- loop> [ run ] when ;
-
-: button* ( string quot -- button ) closed-quot <bevel-button> ;
-
-: toggle-loop ( -- ) loop> [ loop off ] [ loop on [ run ] in-thread ] if ;
-
-VARS: population-label cohesion-label alignment-label separation-label ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: update-population-label ( -- )
- "Population: " boids> length number>string append
- 20 32 pad-right population-label> set-label-string ;
-
-: add-10-boids ( -- )
- boids> 10 random-boids append >boids update-population-label ;
-
-: sub-10-boids ( -- )
- boids> 10 tail >boids update-population-label ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: truncate-value ( n -- n ) 10 * round 10 / ;
-
-: update-cohesion-label ( -- )
- "Cohesion: " cohesion-weight> truncate-value number>string append
- 20 32 pad-right cohesion-label> set-label-string ;
-
-: update-alignment-label ( -- )
- "Alignment: " alignment-weight> truncate-value number>string append
- 20 32 pad-right alignment-label> set-label-string ;
-
-: update-separation-label ( -- )
- "Separation: " separation-weight> truncate-value number>string append
- 20 32 pad-right separation-label> set-label-string ;
-
-: inc-cohesion-weight ( -- ) cohesion-weight inc* update-cohesion-label ;
-: dec-cohesion-weight ( -- ) cohesion-weight dec* update-cohesion-label ;
-
-: inc-alignment-weight ( -- ) alignment-weight inc* update-alignment-label ;
-: dec-alignment-weight ( -- ) alignment-weight dec* update-alignment-label ;
-
-: inc-separation-weight ( -- ) separation-weight inc* update-separation-label ;
-: dec-separation-weight ( -- ) separation-weight dec* update-separation-label ;
-
-: boids-window* ( -- )
- init-variables init-world-size init-boids loop on
-
- "" <label> reverse-video-theme >population-label update-population-label
- "" <label> reverse-video-theme >cohesion-label update-cohesion-label
- "" <label> reverse-video-theme >alignment-label update-alignment-label
- "" <label> reverse-video-theme >separation-label update-separation-label
-
- <frame>
-
- <shelf>
-
- 1 >>fill
-
- "ESC - Pause" [ drop toggle-loop ] button* add-gadget
-
- "1 - Randomize" [ drop randomize ] button* add-gadget
-
- <pile> 1 >>fill
- population-label> add-gadget
- "3 - Add 10" [ drop add-10-boids ] button* add-gadget
- "2 - Sub 10" [ drop sub-10-boids ] button* add-gadget
- add-gadget
-
- <pile> 1 >>fill
- cohesion-label> add-gadget
- "q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
- "a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget
- add-gadget
-
- <pile> 1 >>fill
- alignment-label> add-gadget
- "w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
- "s - -0.1" [ drop dec-alignment-weight ] button* add-gadget
- add-gadget
-
- <pile> 1 >>fill
- separation-label> add-gadget
- "e - +0.1" [ drop inc-separation-weight ] button* add-gadget
- "d - -0.1" [ drop dec-separation-weight ] button* add-gadget
- add-gadget
-
- @top grid-add
-
- C[ display ] <slate>
- dup >slate
- t >>clipped?
- { 600 400 } >>pdim
- C[ [ run ] in-thread ] >>graft
- C[ loop off ] >>ungraft
- @center grid-add
-
- <handler>
- H{ } clone
- T{ key-down f f "1" } C[ drop randomize ] is
- T{ key-down f f "2" } C[ drop sub-10-boids ] is
- T{ key-down f f "3" } C[ drop add-10-boids ] is
- T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is
- T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is
- T{ key-down f f "w" } C[ drop inc-alignment-weight ] is
- T{ key-down f f "s" } C[ drop dec-alignment-weight ] is
- T{ key-down f f "e" } C[ drop inc-separation-weight ] is
- T{ key-down f f "d" } C[ drop dec-separation-weight ] is
- T{ key-down f f "ESC" } C[ drop toggle-loop ] is
- >>table
-
- "Boids" open-window ;
-
-: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
-
-MAIN: boids-window
From c2d475b4b4a10e022fa3f39be3c8807c1bb550d7 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 1 Dec 2008 13:17:22 -0600
Subject: [PATCH 4/7] Remove various files under 'boids.ui'
---
extra/boids/ui/authors.txt | 1 -
extra/boids/ui/deploy.factor | 15 ---------------
extra/boids/ui/tags.txt | 1 -
3 files changed, 17 deletions(-)
delete mode 100755 extra/boids/ui/authors.txt
delete mode 100755 extra/boids/ui/deploy.factor
delete mode 100644 extra/boids/ui/tags.txt
diff --git a/extra/boids/ui/authors.txt b/extra/boids/ui/authors.txt
deleted file mode 100755
index 6cfd5da273..0000000000
--- a/extra/boids/ui/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Eduardo Cavazos
diff --git a/extra/boids/ui/deploy.factor b/extra/boids/ui/deploy.factor
deleted file mode 100755
index 8b3c0baf76..0000000000
--- a/extra/boids/ui/deploy.factor
+++ /dev/null
@@ -1,15 +0,0 @@
-USING: tools.deploy.config ;
-H{
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { deploy-ui? t }
- { deploy-io 2 }
- { deploy-threads? t }
- { deploy-word-defs? f }
- { deploy-compiler? t }
- { deploy-unicode? f }
- { deploy-name "Boids" }
- { "stop-after-last-window?" t }
- { deploy-reflection 1 }
-}
diff --git a/extra/boids/ui/tags.txt b/extra/boids/ui/tags.txt
deleted file mode 100644
index cb5fc203e1..0000000000
--- a/extra/boids/ui/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-demos
From 43889cb587e2746da80986f83da61a1bb975e294 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 1 Dec 2008 13:19:45 -0600
Subject: [PATCH 5/7] boids: Complete rewrite
---
extra/boids/boids.factor | 490 ++++++++++++++++++++++++---------------
1 file changed, 309 insertions(+), 181 deletions(-)
diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor
index 857abcf5d3..b0d5bda508 100644
--- a/extra/boids/boids.factor
+++ b/extra/boids/boids.factor
@@ -1,81 +1,44 @@
-USING: kernel namespaces
- math
- math.constants
- math.functions
- math.order
- math.vectors
- math.trig
- math.ranges
- combinators arrays sequences random vars
- combinators.lib
- combinators.short-circuit
+USING: kernel
+ namespaces
+ arrays
accessors
+ strings
+ sequences
+ locals
+ threads
+ math
+ math.functions
+ math.trig
+ math.order
+ math.ranges
+ math.vectors
+ random
+ calendar
+ opengl.gl
+ opengl
+ ui
+ ui.gadgets
+ ui.gadgets.tracks
+ ui.gadgets.frames
+ ui.gadgets.grids
+ ui.render
+ multi-methods
+ multi-method-syntax
+ combinators.short-circuit.smart
+ processing.shapes
flatland ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
IN: boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: boid < <vel> ;
-
-C: <boid> boid
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: boids
-VAR: world-size
-VAR: time-slice
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: cohesion-weight
-VAR: alignment-weight
-VAR: separation-weight
-
-VAR: cohesion-view-angle
-VAR: alignment-view-angle
-VAR: separation-view-angle
-
-VAR: cohesion-radius
-VAR: alignment-radius
-VAR: separation-radius
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-variables ( -- )
- 1.0 >cohesion-weight
- 1.0 >alignment-weight
- 1.0 >separation-weight
-
- 75 >cohesion-radius
- 50 >alignment-radius
- 25 >separation-radius
-
- 180 >cohesion-view-angle
- 180 >alignment-view-angle
- 180 >separation-view-angle
-
- 10 >time-slice ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! random-boid and random-boids
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-pos ( -- pos ) world-size> [ random ] map ;
-
-: random-vel ( -- vel ) 2 [ drop -10 10 [a,b] random ] map ;
-
-: random-boid ( -- boid ) random-pos random-vel <boid> ;
-
-: random-boids ( n -- boids ) [ drop random-boid ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: constrain ( n a b -- n ) rot min max ;
: angle-between ( vec vec -- angle )
- 2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
+ [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -86,19 +49,47 @@ VAR: separation-radius
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: in-radius? ( self other radius -- ? ) [ distance ] dip <= ;
+: in-view? ( self other angle -- ? ) [ relative-angle ] dip 2 / <= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
: average-position ( boids -- pos ) [ pos>> ] map vaverage ;
-
: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: in-range? ( self other radius -- ? ) >r distance r> <= ;
+TUPLE: <boid> < <vel> ;
-: in-view? ( self other angle -- ? ) >r relative-angle r> 2 / <= ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <behaviour>
+ { weight initial: 1.0 }
+ { view-angle initial: 180 }
+ { radius } ;
+
+TUPLE: <cohesion> < <behaviour> { radius initial: 75 } ;
+TUPLE: <alignment> < <behaviour> { radius initial: 50 } ;
+TUPLE: <separation> < <behaviour> { radius initial: 25 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: within-neighborhood? ( SELF OTHER BEHAVIOUR -- ? )
+
+ SELF OTHER
+ {
+ [ BEHAVIOUR radius>> in-radius? ]
+ [ BEHAVIOUR view-angle>> in-view? ]
+ [ eq? not ]
+ }
+ && ;
+
+:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
+ OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -106,127 +97,264 @@ VAR: separation-radius
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! average_position(neighbors) - self_position
+GENERIC: force* ( sequence <boid> <behaviour> -- force )
-: within-cohesion-neighborhood? ( self other -- ? )
- { [ cohesion-radius> in-range? ]
- [ cohesion-view-angle> in-view? ]
- [ eq? not ] }
- 2&& ;
+:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
+ OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
-: cohesion-neighborhood ( self -- boids )
- boids> [ within-cohesion-neighborhood? ] with filter ;
+:: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
+ OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ;
-: cohesion-force ( self -- force )
- dup cohesion-neighborhood
- dup empty?
- [ 2drop { 0 0 } ]
- [ average-position swap pos>> v- normalize* cohesion-weight> v*n ]
+:: separation-force ( OTHERS SELF BEHAVIOUR -- force )
+ SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ;
+
+METHOD: force* ( sequence <boid> <cohesion> -- force ) cohesion-force ;
+METHOD: force* ( sequence <boid> <alignment> -- force ) alignment-force ;
+METHOD: force* ( sequence <boid> <separation> -- force ) separation-force ;
+
+:: force ( OTHERS SELF BEHAVIOUR -- force )
+ SELF OTHERS BEHAVIOUR neighborhood
+ [ { 0 0 } ]
+ [ SELF BEHAVIOUR force* ]
+ if-empty ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: random-boids ( count -- boids )
+ [
+ drop
+ <boid> new
+ 2 [ drop 1000 random ] map >>pos
+ 2 [ drop -10 10 [a,b] random ] map >>vel
+ ]
+ map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-boid ( boid -- )
+ glPushMatrix
+ dup pos>> gl-translate-2d
+ vel>> first2 rect> arg rad>deg 0 0 1 glRotated
+ { { 0 5 } { 0 -5 } { 20 0 } } triangle
+ fill-mode
+ glPopMatrix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gadget->sky ( gadget -- sky ) { 0 0 } swap dim>> <rectangle> boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
+
+TUPLE: <boids-gadget> < gadget paused boids behaviours time-slice ;
+
+M: <boids-gadget> pref-dim* ( <boids-gadget> -- dim ) drop { 600 400 } ;
+M: <boids-gadget> ungraft* ( <boids-gadget> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
+
+ [let | SKY [ BOIDS-GADGET gadget->sky ]
+ BOIDS [ BOIDS-GADGET boids>> ]
+ TIME-SLICE [ BOIDS-GADGET time-slice>> ]
+ BEHAVIOURS [ BOIDS-GADGET behaviours>> ] |
+
+ BOIDS
+
+ [| SELF |
+
+ [wlet | force-due-to [| BEHAVIOUR | BOIDS SELF BEHAVIOUR force ] |
+
+ ! F = m a. M is 1. So F = a.
+
+ [let | ACCEL [ BEHAVIOURS [ force-due-to ] map vsum ] |
+
+ [let | POS [ SELF pos>> SELF vel>> TIME-SLICE v*n v+ ]
+ VEL [ SELF vel>> ACCEL TIME-SLICE v*n v+ ] |
+
+ [let | POS [ POS SKY wrap ]
+ VEL [ VEL normalize* ] |
+
+ T{ <boid> f POS VEL } ] ] ] ]
+
+ ]
+
+ map
+
+ BOIDS-GADGET (>>boids)
+
+ origin get
+ [ BOIDS-GADGET boids>> [ draw-boid ] each ]
+ with-translation ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-boids-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET relayout-1 25 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-behaviours ( -- seq )
+ { <cohesion> <alignment> <separation> } [ new ] map ;
+
+: boids-gadget ( -- gadget )
+ <boids-gadget> new-gadget
+ 100 random-boids >>boids
+ default-behaviours >>behaviours
+ 10 >>time-slice
+ t >>clipped? ;
+
+: run-boids ( -- ) boids-gadget dup "Boids" open-window start-boids-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: math.parser
+ ui.gadgets.labels
+ ui.gadgets.buttons
+ ui.gadgets.packs ;
+
+: truncate-number ( n -- n ) 10 * round 10 / ;
+
+:: make-behaviour-control ( NAME BEHAVIOUR -- gadget )
+ [let | NAME-LABEL [ NAME <label> reverse-video-theme ]
+ VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
+
+ [wlet | update-value-label [ ! ( -- )
+ BEHAVIOUR weight>> truncate-number number>string
+ VALUE-LABEL
+ set-label-string ] |
+
+ update-value-label
+
+ <pile> 1 >>fill
+ { 1 0 } <track>
+ NAME-LABEL 0.5 track-add
+ VALUE-LABEL 0.5 track-add
+ add-gadget
+
+ "+0.1"
+ [
+ drop
+ BEHAVIOUR [ 0.1 + ] change-weight drop
+ update-value-label
+ ]
+ <bevel-button> add-gadget
+
+ "-0.1"
+ [
+ drop
+ BEHAVIOUR weight>> 0.1 >
+ [
+ BEHAVIOUR [ 0.1 - ] change-weight drop
+ update-value-label
+ ]
+ when
+ ]
+ <bevel-button> add-gadget ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: make-population-control ( BOIDS-GADGET -- gadget )
+ [let | VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
+
+ [wlet | update-value-label [ ( -- )
+ BOIDS-GADGET boids>> length number>string
+ VALUE-LABEL
+ set-label-string ] |
+
+ update-value-label
+
+ <pile> 1 >>fill
+
+ { 1 0 } <track>
+ "Population: " <label> reverse-video-theme 0.5 track-add
+ VALUE-LABEL 0.5 track-add
+ add-gadget
+
+ "Add 10"
+ [
+ drop
+ BOIDS-GADGET
+ BOIDS-GADGET boids>> 10 random-boids append
+ >>boids
+ drop
+ update-value-label
+ ]
+ <bevel-button>
+ add-gadget
+
+ "Sub 10"
+ [
+ drop
+ BOIDS-GADGET boids>> length 10 >
+ [
+ BOIDS-GADGET
+ BOIDS-GADGET boids>> 10 tail
+ >>boids
+ drop
+ update-value-label
+ ]
+ when
+ ]
+ <bevel-button>
+ add-gadget ] ] ( gadget -- gadget ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: pause-toggle ( BOIDS-GADGET -- )
+ BOIDS-GADGET paused>>
+ [ BOIDS-GADGET start-boids-thread ]
+ [ BOIDS-GADGET t >>paused drop ]
if ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+:: randomize-boids ( BOIDS-GADGET -- )
+ BOIDS-GADGET BOIDS-GADGET boids>> length random-boids >>boids drop ;
-! self_position - average_position(neighbors)
+: boids-app ( -- )
-: within-separation-neighborhood? ( self other -- ? )
- { [ separation-radius> in-range? ]
- [ separation-view-angle> in-view? ]
- [ eq? not ] }
- 2&& ;
+ [let | BOIDS-GADGET [ boids-gadget ] |
-: separation-neighborhood ( self -- boids )
- boids> [ within-separation-neighborhood? ] with filter ;
+ <frame>
-: separation-force ( self -- force )
- dup separation-neighborhood
- dup empty?
- [ 2drop { 0 0 } ]
- [ average-position swap pos>> swap v- normalize* separation-weight> v*n ]
- if ;
+ <shelf>
+
+ 1 >>fill
+
+ "Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
+
+ "Randomize"
+ [ drop BOIDS-GADGET randomize-boids ] <bevel-button> add-gadget
+
+ BOIDS-GADGET make-population-control add-gadget
+
+ "Cohesion: " BOIDS-GADGET behaviours>> first make-behaviour-control
+ "Alignment: " BOIDS-GADGET behaviours>> second make-behaviour-control
+ "Separation: " BOIDS-GADGET behaviours>> third make-behaviour-control
+
+ [ add-gadget ] tri@
+
+ @top grid-add
+
+ BOIDS-GADGET @center grid-add
+
+ "Boids" open-window
+
+ BOIDS-GADGET start-boids-thread ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! average_velocity(neighbors)
-
-: within-alignment-neighborhood? ( self other -- ? )
- { [ alignment-radius> in-range? ]
- [ alignment-view-angle> in-view? ]
- [ eq? not ] }
- 2&& ;
-
-: alignment-neighborhood ( self -- boids )
- boids> [ within-alignment-neighborhood? ] with filter ;
-
-: alignment-force ( self -- force )
- alignment-neighborhood
- dup empty?
- [ drop { 0 0 } ]
- [ average-velocity normalize* alignment-weight> v*n ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! F = m a
-!
-! We let m be equal to 1 so then this is simply: F = a
-
-: acceleration ( boid -- acceleration )
- { separation-force alignment-force cohesion-force } map-exec-with vsum ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! iterate-boid
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: world-width ( -- w ) world-size> first ;
-
-: world-height ( -- w ) world-size> second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: below? ( n a b -- ? ) drop < ;
-
-: above? ( n a b -- ? ) nip > ;
-
-: wrap ( n a b -- n )
- {
- { [ 3dup below? ] [ 2nip ] }
- { [ 3dup above? ] [ drop nip ] }
- { [ t ] [ 2drop ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: wrap-x ( x -- x ) 0 world-width 1- wrap ;
-
-: wrap-y ( y -- y ) 0 world-height 1- wrap ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new-pos ( boid -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
-
-: new-vel ( boid -- vel )
- [ vel>> ] [ acceleration time-slice> v*n ] bi v+ normalize* ;
-
-: wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ;
-
-: iterate-boid ( self -- self ) [ new-pos wrap-pos ] [ new-vel ] bi <boid> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: iterate-boids ( -- ) boids> [ iterate-boid ] map >boids ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-boids ( -- ) 100 random-boids >boids ;
-
-: init-world-size ( -- ) { 100 100 } >world-size ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: randomize ( -- ) boids> length random-boids >boids ;
-
-: inc* ( variable -- ) dup get 0.1 + 0 1 constrain swap set ;
-
-: dec* ( variable -- ) dup get 0.1 - 0 1 constrain swap set ;
+: boids-main ( -- ) [ boids-app ] with-ui ;
+MAIN: boids-main
\ No newline at end of file
From a558f91d5d276fd3b3a602d119725c32c07d5721 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Dec 2008 16:10:48 -0600
Subject: [PATCH 6/7] Better command-line processing
---
basis/bootstrap/stage2.factor | 11 ++--
basis/command-line/command-line-docs.factor | 49 ++++++++++++-----
basis/command-line/command-line.factor | 60 ++++++++++++++-------
basis/cpu/x86/32/32.factor | 2 +-
basis/help/cookbook/cookbook.factor | 29 ++++++++--
basis/tools/vocabs/monitor/monitor.factor | 5 +-
core/vocabs/loader/loader-docs.factor | 17 +++---
core/vocabs/loader/loader.factor | 5 +-
8 files changed, 122 insertions(+), 56 deletions(-)
diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index f310944d02..4ab36ec94e 100644
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -59,9 +59,9 @@ SYMBOL: bootstrap-time
"math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global
- parse-command-line
+ (command-line) parse-command-line
- "-no-crossref" cli-args member? [ do-crossref ] unless
+ do-crossref
! Set dll paths
os wince? [ "windows.ce" require ] when
@@ -92,12 +92,7 @@ SYMBOL: bootstrap-time
[
boot
do-init-hooks
- [
- parse-command-line
- run-user-init
- "run" get run
- output-stream get [ stream-flush ] when*
- ] [ print-error 1 exit ] recover
+ handle-command-line
] set-boot-quot
millis swap - bootstrap-time set-global
diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor
index 65d290df3a..3d06bd97b7 100644
--- a/basis/command-line/command-line-docs.factor
+++ b/basis/command-line/command-line-docs.factor
@@ -1,4 +1,5 @@
-USING: help.markup help.syntax parser vocabs.loader strings ;
+USING: help.markup help.syntax parser vocabs.loader strings
+command-line.private ;
IN: command-line
HELP: run-bootstrap-init
@@ -7,7 +8,10 @@ HELP: run-bootstrap-init
HELP: run-user-init
{ $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ;
-HELP: cli-param
+HELP: load-vocab-roots
+{ $description "Loads the newline-separated list of additional vocabulary roots from the file named " { $snippet ".factor-roots" } " on Unix and " { $snippet "factor-roots" } " on Windows." } ;
+
+HELP: param
{ $values { "param" string } }
{ $description "Process a command-line switch."
$nl
@@ -17,10 +21,13 @@ $nl
$nl
"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
-HELP: cli-args
+HELP: (command-line)
{ $values { "args" "a sequence of strings" } }
{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
+HELP: command-line
+{ $var-description "The command line parameters which follow the name of the script on the command line." } ;
+
HELP: main-vocab-hook
{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
@@ -35,9 +42,6 @@ HELP: ignore-cli-args?
{ $values { "?" "a boolean" } }
{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
-HELP: parse-command-line
-{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;
-
ARTICLE: "runtime-cli-args" "Command line switches for the VM"
"A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $table
@@ -64,9 +68,12 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
}
"Bootstrap can load various optional components:"
{ $table
+ { { $snippet "math" } "Rational and complex number support." }
+ { { $snippet "threads" } "Thread support." }
{ { $snippet "compiler" } "The compiler." }
{ { $snippet "tools" } "Terminal-based developer tools." }
{ { $snippet "help" } "The help system." }
+ { { $snippet "help.handbook" } "The help handbook." }
{ { $snippet "ui" } "The graphical user interface." }
{ { $snippet "ui.tools" } "Graphical developer tools." }
{ { $snippet "io" } "Non-blocking I/O and networking." }
@@ -86,7 +93,6 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
{ { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } }
- { { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
} ;
ARTICLE: "factor-boot-rc" "Bootstrap initialization file"
@@ -102,11 +108,18 @@ $nl
"A word to run this file from an existing Factor session:"
{ $subsection run-user-init } ;
+ARTICLE: "factor-roots" "Additional vocabulary roots file"
+"The vocabulary roots file is named " { $snippet "factor-roots" } " on Windows and " { $snippet ".factor-roots" } " on Unix. If it exists, it is loaded every time Factor starts. It contains a newline-separated list of " { $link "vocabs.roots" } "."
+$nl
+"A word to run this file from an existing Factor session:"
+{ $subsection load-vocab-roots } ;
+
ARTICLE: "rc-files" "Running code on startup"
-"Factor looks for two files in your home directory."
+"Factor looks for three optional files in your home directory."
{ $subsection "factor-boot-rc" }
{ $subsection "factor-rc" }
-"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files."
+{ $subsection "factor-roots" }
+"The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files."
$nl
"If you are unsure where the files should be located, evaluate the following code:"
{ $code
@@ -122,8 +135,16 @@ $nl
"100 dpi set-global"
} ;
-ARTICLE: "cli" "Command line usage"
-"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "."
+ARTICLE: "cli" "Command line arguments"
+"Factor command line usage:"
+{ $code "factor [system switches...] [script args...]" }
+"Zero or more system switches can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in a variable, with no further processing by Factor itself:"
+{ $subsection command-line }
+"Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:"
+{ $code "factor [system switches...] -run=<vocab name>" }
+"If no script file or " { $snippet "-run=" } " switch is specified, Factor will start " { $link "listener" } " or " { $link "ui-tools" } ", depending on the operating system."
+$nl
+"As stated above, arguments in the first part of the command line, before the optional script name, are interpreted by to the Factor system. These arguments all start with a dash (" { $snippet "-" } ")."
$nl
"Switches can take one of the following three forms:"
{ $list
@@ -134,9 +155,9 @@ $nl
{ $subsection "runtime-cli-args" }
{ $subsection "bootstrap-cli-args" }
{ $subsection "standard-cli-args" }
-"The list of command line arguments can be obtained and inspected directly:"
-{ $subsection cli-args }
-"There is a way to override the default vocabulary to run on startup:"
+"The raw list of command line arguments can also be obtained and inspected directly:"
+{ $subsection (command-line) }
+"There is a way to override the default vocabulary to run on startup, if no script name or " { $snippet "-run" } " switch is specified:"
{ $subsection main-vocab-hook } ;
ABOUT: "cli"
diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor
index 7691f6877b..1b58053b64 100644
--- a/basis/command-line/command-line.factor
+++ b/basis/command-line/command-line.factor
@@ -1,10 +1,15 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: init continuations debugger hashtables io kernel
-kernel.private namespaces parser sequences strings system
-splitting io.files eval ;
+USING: init continuations debugger hashtables io
+io.encodings.utf8 io.files kernel kernel.private namespaces
+parser sequences strings system splitting eval vocabs.loader ;
IN: command-line
+SYMBOL: script
+SYMBOL: command-line
+
+: (command-line) ( -- args ) 10 getenv sift ;
+
: rc-path ( name -- path )
os windows? [ "." prepend ] unless
home prepend-path ;
@@ -19,17 +24,33 @@ IN: command-line
"factor-rc" rc-path ?run-file
] when ;
-: cli-var-param ( name value -- ) swap set-global ;
+: load-vocab-roots ( -- )
+ "user-init" get [
+ "factor-roots" rc-path dup exists? [
+ utf8 file-lines [ add-vocab-root ] each
+ ] [ drop ] if
+ ] when ;
-: cli-bool-param ( name -- ) "no-" ?head not cli-var-param ;
+<PRIVATE
-: cli-param ( param -- )
- "=" split1 [ cli-var-param ] [ cli-bool-param ] if* ;
+: var-param ( name value -- ) swap set-global ;
-: cli-arg ( argument -- argument )
- "-" ?head [ cli-param f ] when ;
+: bool-param ( name -- ) "no-" ?head not var-param ;
-: cli-args ( -- args ) 10 getenv ;
+: param ( param -- )
+ "=" split1 [ var-param ] [ bool-param ] if* ;
+
+: run-script ( file -- )
+ t "quiet" set-global run-file ;
+
+PRIVATE>
+
+: parse-command-line ( args -- )
+ [ command-line off script off ] [
+ unclip "-" ?head
+ [ param parse-command-line ]
+ [ script set command-line set ] if
+ ] if-empty ;
SYMBOL: main-vocab-hook
@@ -53,14 +74,17 @@ SYMBOL: main-vocab-hook
: ignore-cli-args? ( -- ? )
os macosx? "run" get "ui" = and ;
-: script-mode ( -- )
- t "quiet" set-global
- "none" "run" set-global ;
+: script-mode ( -- ) ;
-: parse-command-line ( -- )
- cli-args [ cli-arg ] filter
- "script" get [ script-mode ] when
- ignore-cli-args? [ drop ] [ [ run-file ] each ] if
- "e" get [ eval ] when* ;
+: handle-command-line ( -- )
+ [
+ (command-line) parse-command-line
+ load-vocab-roots
+ run-user-init
+ "e" get [ eval ] when*
+ ignore-cli-args? not script get and
+ [ run-script ] [ "run" get run ] if*
+ output-stream get [ stream-flush ] when*
+ ] [ print-error 1 exit ] recover ;
[ default-cli-args ] "command-line" add-init-hook
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 9fd1330757..3df072208d 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -307,7 +307,7 @@ FUNCTION: bool check_sse2 ( ) ;
: sse2? ( -- ? )
check_sse2 ;
-"-no-sse2" cli-args member? [
+"-no-sse2" (command-line) member? [
[ optimized-recompile-hook ] recompile-hook
[ { check_sse2 } compile ] with-variable
diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor
index 711712a4bc..a957cb3e72 100644
--- a/basis/help/cookbook/cookbook.factor
+++ b/basis/help/cookbook/cookbook.factor
@@ -1,6 +1,6 @@
USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces stack-checker
-help ;
+help command-line multiline ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
@@ -263,11 +263,30 @@ ARTICLE: "cookbook-application" "Application cookbook"
ARTICLE: "cookbook-scripts" "Scripting cookbook"
"Factor can be used for command-line scripting on Unix-like systems."
$nl
-"A text file can begin with a comment like the following, and made executable:"
-{ $code "#! /usr/bin/env factor -script" }
-"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
+"To run a script, simply pass it as an argument to the Factor executable:"
+{ $code "./factor cleanup.factor" }
+"The script may access command line arguments by inspecting the value of the " { $link command-line } " variable. It can also get its own path from the " { $link script } " variable."
$nl
-"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes."
+"Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:"
+{ $code
+ <" USING: command-line namespaces io io.files io.files.listing
+sequences kernel ;
+
+command-line get [
+ current-directory get directory.
+] [
+ dup length 1 = [ first directory. ] [
+ [ [ nl write ":" print ] [ directory. ] bi ] each
+ ] if
+] if-empty">
+}
+"You can put it in a file named " { $snippet "ls.factor" } ", and then run it, to list the " { $snippet "/usr/bin" } " directory for example:"
+{ $code "./factor ls.factor /usr/bin" }
+"It is also possible to make executable scripts. A Factor file can begin with a comment like the following:"
+{ $code "#! /usr/bin/env factor" }
+"If the text file is made executable, then it can be run, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
+$nl
+"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result."
{ $references
{ }
"cli"
diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/tools/vocabs/monitor/monitor.factor
index ed2e486ecc..416eec91d2 100644
--- a/basis/tools/vocabs/monitor/monitor.factor
+++ b/basis/tools/vocabs/monitor/monitor.factor
@@ -54,7 +54,6 @@ TR: convert-separators "/\\" ".." ;
[ monitor-thread ] "Vocabulary monitor" spawn drop ;
[
- "-no-monitors" cli-args member? [
- start-monitor-thread
- ] unless
+ "-no-monitors" (command-line) member?
+ [ start-monitor-thread ] unless
] "tools.vocabs.monitor" add-init-hook
diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor
index 89b8a0728d..d658a8e033 100644
--- a/core/vocabs/loader/loader-docs.factor
+++ b/core/vocabs/loader/loader-docs.factor
@@ -12,12 +12,12 @@ ARTICLE: "vocabs.roots" "Vocabulary roots"
{ { $snippet "extra" } " - additional contributed libraries." }
{ { $snippet "work" } " - a root for vocabularies which are not intended to be contributed back to Factor." }
}
-"Your own vocabularies should go into " { $snippet "extra" } " or " { $snippet "work" } ", depending on whether or not you intend to contribute them back to the Factor project. If you wish to work on vocabularies outside of the Factor source directory, create a " { $link "factor-boot-rc" } " file like the following:"
-{ $code
- "USING: namespaces sequences vocabs.loader ;"
- "\"/home/jane/sources/\" vocab-roots get push"
-}
-"See " { $link "rc-files" } " for details." ;
+"You can store your own vocabularies in the " { $snippet "work" } " directory. You can also store code outside of the Factor source tree by making Factor aware of it first. There are two ways of doing this."
+$nl
+"You can list additional vocabulary roots in a file that Factor reads at startup:"
+{ $subsection "factor-roots" }
+"Or you can add them dynamically using a word:"
+{ $subsection add-vocab-root } ;
ARTICLE: "vocabs.loader" "Vocabulary loader"
"The vocabulary loader is defined in the " { $vocab-link "vocabs.loader" } " vocabulary."
@@ -57,6 +57,11 @@ HELP: vocab-main
HELP: vocab-roots
{ $var-description "A sequence of pathname strings to search for vocabularies." } ;
+HELP: add-vocab-root
+{ $values { "path" "a pathname string" } }
+{ $description "Adds a directory pathname to the list of vocabulary roots." }
+{ $see-also "factor-roots" } ;
+
HELP: find-vocab-root
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 49fad2626f..6fb0d08811 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -3,7 +3,7 @@
USING: namespaces make sequences io.files kernel assocs words
vocabs definitions parser continuations io hashtables sorting
source-files arrays combinators strings system math.parser
-compiler.errors splitting init accessors ;
+compiler.errors splitting init accessors sets ;
IN: vocabs.loader
SYMBOL: vocab-roots
@@ -15,6 +15,9 @@ V{
"resource:work"
} clone vocab-roots set-global
+: add-vocab-root ( root -- )
+ vocab-roots get adjoin ;
+
: vocab-dir ( vocab -- dir )
vocab-name { { CHAR: . CHAR: / } } substitute ;
From 7b392c88e6bb5e79d203d986a1b46c2f6311ade6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Dec 2008 16:12:04 -0600
Subject: [PATCH 7/7] Remove obsolete tests
---
basis/command-line/command-line-tests.factor | 12 ------------
1 file changed, 12 deletions(-)
delete mode 100644 basis/command-line/command-line-tests.factor
diff --git a/basis/command-line/command-line-tests.factor b/basis/command-line/command-line-tests.factor
deleted file mode 100644
index 226765bafe..0000000000
--- a/basis/command-line/command-line-tests.factor
+++ /dev/null
@@ -1,12 +0,0 @@
-USING: namespaces tools.test kernel command-line ;
-IN: command-line.tests
-
-[
- [ f ] [ "-no-user-init" cli-arg ] unit-test
- [ f ] [ "user-init" get ] unit-test
-
- [ f ] [ "-user-init" cli-arg ] unit-test
- [ t ] [ "user-init" get ] unit-test
-
- [ "sdl.factor" ] [ "sdl.factor" cli-arg ] unit-test
-] with-scope