[ dup 0 = ] [
[ pick underlying>> pick set-alien-unsigned-1 ] keep
[ 1+ ] [ -8 shift ] bi*
- ] [ ] until 2drop
+ ] until 2drop
] if ;
: bit-array>integer ( bit-array -- n )
[ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test
-[ V{ real } ] [ [ [ dup 10 < ] [ ] [ ] while ] final-classes ] unit-test
+[ V{ real } ] [ [ [ dup 10 < ] [ ] while ] final-classes ] unit-test
[ V{ float } ] [
[ { float } declare 10 [ 2.3 * ] times ] final-classes
f mailbox-get-all-timeout ;\r
\r
: while-mailbox-empty ( mailbox quot -- )\r
- [ '[ _ mailbox-empty? ] ] dip [ ] while ; inline\r
+ [ '[ _ mailbox-empty? ] ] dip while ; inline\r
\r
: mailbox-get-timeout? ( mailbox timeout pred -- obj )\r
[ block-unless-pred ]\r
: slurp-deque ( deque quot -- )
[ drop '[ _ deque-empty? not ] ]
[ '[ _ pop-back @ ] ]
- 2bi [ ] while ; inline
+ 2bi while ; inline
MIXIN: deque
[ dup 10.0 >=
[ 10.0 / [ 1+ ] dip ]
[ 10.0 * [ 1- ] dip ] if
- ] [ ] while
+ ] while
] keep 0 < [ neg ] when ;
: exp>string ( exp base digits -- string )
! Non-recursive
[ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
- [ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail
+ [ [ t ] [ "m" get next-change drop ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
! Recursive
[ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
- [ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail
+ [ [ t ] [ "m" get next-change drop ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
] with-monitors
] when
: acquire-connection ( pool -- conn )
dup check-pool
- [ dup connections>> empty? ] [ dup new-connection ] [ ] while
+ [ dup connections>> empty? ] [ dup new-connection ] while
connections>> pop ;
: (with-pooled-connection) ( conn pool quot -- )
sleep-time io-multiplex yield ;\r
\r
: start-io-thread ( -- )\r
- [ [ io-thread-running? get-global ] [ io-thread ] [ ] while ]\r
+ [ [ io-thread-running? get-global ] [ io-thread ] while ]\r
"I/O wait" spawn drop ;\r
\r
[\r
: factor-2s ( n -- r s )
#! factor an integer into 2^r * s
dup 0 = [ 1 ] [
- 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while
+ 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while
] if ; inline
<PRIVATE
: count-factor ( n d -- n' c )
[ 1 ] 2dip [ /i ] keep
- [ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] [ drop ] while
+ [ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] while drop
swap ;
: write-factor ( n d -- n' d )
: group-factors ( n -- seq )
[
2
- [ 2dup sq < ] [ write-factor next-prime ] [ ] until
+ [ 2dup sq < ] [ write-factor next-prime ] until
drop dup 2 < [ drop ] [ 1 2array , ] if
] { } make ;
} cond ; foldable
: next-prime ( n -- p )
- next-odd [ dup really-prime? ] [ 2 + ] [ ] until ; foldable
+ next-odd [ dup really-prime? ] [ 2 + ] until ; foldable
: primes-between ( low high -- seq )
[ dup 3 max dup even? [ 1 + ] when ] dip
: randomize ( seq -- seq )
dup length [ dup 1 > ]
[ [ random ] [ 1- ] bi [ pick exchange ] keep ]
- [ ] while drop ;
+ while drop ;
: delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep delete-nth ;
! Corner case
[ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail
-[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
+[ [ [ f dup ] [ ] while ] infer ] must-fail
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
sleep-queue
[ dup expire-sleep? ]
[ dup heap-pop drop expire-sleep ]
- [ ] while
+ while
drop ;
: start ( namestack thread -- * )
]
} case
] handle-synchronous
- ] [ ] while ;
+ ] while ;
: step-back-msg ( continuation -- continuation' )
walker-history tget
{ step-back [ step-back-msg ] }
} case f
] handle-synchronous
- ] [ ] while ;
+ ] while ;
: walker-loop ( -- )
+running+ set-status
[ walker-suspended ]
} case
] handle-synchronous
- ] [ ] until ;
+ ] until ;
: associate-thread ( walker -- )
walker-thread tset
HOOK: do-events ui-backend ( -- )
-: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
+: event-loop ( -- ) [ event-loop? ] [ do-events ] while ;
: ui-wait ( -- ) 10 milliseconds sleep ;
! This should not throw an exception
[ ] [ "interactor" get evaluate-input ] unit-test
- [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+ [ ] [ [ "interactor" get interactor-busy? ] [ yield ] while ] unit-test
[ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
: update-ui-loop ( -- )
[ ui-running? ui-thread get-global self eq? and ]
[ ui-notify-flag get lower-flag update-ui ]
- [ ] while ;
+ while ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]
<PRIVATE
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
- [ dup ] compose swap [ drop ] while ; inline
+ [ dup ] compose swap while drop ; inline
PRIVATE>
} ;
HELP: while
-{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ;
HELP: until
-{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link t } "." } ;
HELP: do
-{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
{ $description "Executes one iteration of a " { $link while } " or " { $link until } " loop." } ;
HELP: loop
"In most cases, loops should be written using high-level combinators (such as " { $link "sequences-combinators" } ") or tail recursion. However, sometimes, the best way to express intent is with a loop."
{ $subsection while }
{ $subsection until }
-"The above two combinators take a " { $snippet "tail" } " quotation. Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
-{ $code
- "[ P ] [ Q ] [ T ] while"
- "[ P ] [ Q ] [ ] while T"
-}
-"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference."
$nl
"To execute one iteration of a loop, use the following word:"
{ $subsection do }
: either? ( x y quot -- ? ) bi@ or ; inline
-: most ( x y quot -- z )
- [ 2dup ] dip call [ drop ] [ nip ] if ; inline
+: most ( x y quot -- z ) 2keep ? ; inline
! Loops
: loop ( pred: ( -- ? ) -- )
[ call ] keep [ loop ] curry when ; inline recursive
-: do ( pred body tail -- pred body tail )
- over 3dip ; inline
+: do ( pred body -- pred body )
+ dup 2dip ; inline
-: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
- [ pick 3dip [ do while ] 3curry ] keep if ; inline recursive
+: while ( pred: ( -- ? ) body: ( -- ) -- )
+ swap do compose [ loop ] curry when ; inline
-: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
- [ [ not ] compose ] 2dip while ; inline
+: until ( pred: ( -- ? ) body: ( -- ) -- )
+ [ [ not ] compose ] dip while ; inline
! Object protocol
GENERIC: hashcode* ( depth obj -- code )
M: fixnum bit? neg shift 1 bitand 0 > ;
: fixnum-log2 ( x -- n )
- 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] until drop ;
+ 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] until drop ;
M: fixnum (log2) fixnum-log2 ;
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ]
[ [ shift-mantissa ] dip ]
- [ ] while /mod ; inline
+ while /mod ; inline
! Third step: post-scaling
: unscaled-float ( mantissa -- n )
V{ } clone [ [ push ] curry compose ] keep ; inline
: produce-as ( pred quot tail exemplar -- seq )
- [ swap accumulator [ swap while ] dip ] dip like ; inline
+ [ [ accumulator [ while ] dip ] dip dip ] dip like ; inline
: produce ( pred quot tail -- seq )
{ } produce-as ; inline
swap
peel-off-name
peel-off-class
- [ dup empty? ] [ peel-off-attributes ] [ ] until drop
+ [ dup empty? ] [ peel-off-attributes ] until drop
check-initial-value ;
M: slot-spec make-slot
: sort-loop ( merge quot -- )
[ 2 [ over seq>> length over > ] ] dip
[ [ 1 shift 2dup ] dip sort-pass ] curry
- [ ] while 2drop ; inline
+ while 2drop ; inline
: each-pair ( seq quot -- )
[ [ length 1+ 2/ ] keep ] dip
: compute-adjacencies ( solid -- solid )\r
dup dimension>> [ >= ] curry \r
[ keep swap ] curry MAX-FACE-PER-CORNER swap\r
- [ [ test-faces-combinaisons ] 2keep 1- ] [ ] while drop ;\r
+ [ [ test-faces-combinaisons ] 2keep 1- ] while drop ;\r
\r
: find-adjacencies ( solid -- solid ) \r
erase-old-adjacencies \r
0 >>theta-d
0 >>theta-dd
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
drop ;
0 >>theta-d
0 >>theta-dd
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
0 1 0 1 rgba boa >>myc
0 >>theta-d
0 >>theta-dd
- [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
+ [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] while
set-good-color
set-anti-color
0 >>theta-d
0 >>theta-dd
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
drop ;
: full-depth-first ( graph pre post tail -- ? )
'[ [ visited? get [ nip not ] assoc-find ]
[ drop _ _ (depth-first) @ ]
- [ 2drop ] while ] swap search-wrap ; inline
+ while 2drop ] swap search-wrap ; inline
: dag? ( graph -- ? )
V{ } clone swap [ 2dup swap push dupd
: display ( stream tab -- )\r
'[ _ [ [ t ]\r
[ _ dup chat>> hear handle-inbox ]\r
- [ ] while ] with-output-stream ] "ircv" spawn drop ;\r
+ while ] with-output-stream ] "ircv" spawn drop ;\r
\r
: <irc-pane> ( tab -- tab pane )\r
<scrolling-pane>\r
}
{ $slide "Modifiers"
{ $code ": bank ( n -- n )" " readln string>number +" " dup \"Balance: $\" write . ;" }
- { $code "0 [ dup 0 > ] [ bank ] [ ] while" }
+ { $code "0 [ dup 0 > ] [ bank ] while" }
}
{ $slide "Modifiers"
{ $code "0 [ dup 0 > ] [ bank ] [ ] do while" }
! --------
: euler012 ( -- answer )
- 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ;
+ 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] while nth-triangle ;
! [ euler012 ] 10 ave-time
! 6573 ms ave run time - 346.27 SD (10 trials)
PRIVATE>
: collatz ( n -- seq )
- [ [ dup 1 > ] [ dup , next-collatz ] [ ] while , ] { } make ;
+ [ [ dup 1 > ] [ dup , next-collatz ] while , ] { } make ;
: euler014 ( -- answer )
1000000 [1,b] 0 [ collatz longest ] reduce first ;
: euler100 ( -- answer )
1 1
[ dup dup 1- * 2 * 10 24 ^ <= ]
- [ tuck 6 * swap - 2 - ] [ ] while nip ;
+ [ tuck 6 * swap - 2 - ] while nip ;
! TODO: solution needs generalization
r> [ drop \ r> , ] each
] [ ] make ;
-: do-while ( pred body tail -- )
- [ tuck 2slip ] dip while ; inline
-
: generate ( generator predicate -- obj )
- '[ dup @ dup [ nip ] unless not ]
- swap [ ] do-while ;
+ '[ dup @ dup [ nip ] unless ]
+ swap do until ;
MACRO: predicates ( seq -- quot/f )
dup [ 1quotation [ drop ] prepend ] map