USE: lists
USE: stack
-: 2apply ( x y quot -- )
- #! First applies the code to x, then to y.
- #!
- #! If the quotation compiles, this combinator compiles.
- 2dup >r >r nip call r> r> call ; inline interpret-only
-
-: cleave ( x quot quot -- )
- #! Executes each quotation, with x on top of the stack.
- #!
- #! If the quotation compiles, this combinator compiles.
- >r over >r call r> r> call ; inline interpret-only
-
: slip ( quot x -- x )
>r call r> ; inline interpret-only
: 3slip ( quot x y z -- x y z )
>r >r >r call r> r> r> ; inline interpret-only
-: dip ( a [ b ] -- b a )
- #! Call b as if b was not present on the stack.
- #!
- #! If the quotation compiles, this combinator compiles.
- swap >r call r> ; inline interpret-only
-
-: 2dip ( a b [ c ] -- c a b )
- #! Call c as if a and b were not present on the stack.
- #!
- #! If the quotation compiles, this combinator compiles.
- -rot >r >r call r> r> ; inline interpret-only
-
-: forever ( quot -- )
- #! The code is evaluated in an infinite loop. Typically, a
- #! continuation is used to escape the infinite loop.
- #!
- #! This combinator will not compile.
- dup dip forever ; interpret-only
-
: keep ( a quot -- a )
#! Execute the quotation with a on the stack, and restore a
#! after the quotation returns.
over >r call r> ;
+: apply ( code input -- code output )
+ #! Apply code to input.
+ swap dup >r call r> swap ;
+
: cond ( x list -- )
#! The list is of this form:
#!
pick [ drop call ] [ nip nip call ] ifte ;
inline interpret-only
-: interleave ( X quot -- )
- #! Evaluate each element of the list with X on top of the
- #! stack. When done, X is popped off the stack.
- #!
- #! To avoid unexpected results, each element of the list
- #! must have stack effect ( X -- ).
- #!
- #! This combinator will not compile.
- dup [
- over [ unswons dip ] dip swap interleave
- ] [
- 2drop
- ] ifte ; interpret-only
-
: unless ( cond quot -- )
#! Execute a quotation only when the condition is f. The
#! condition is popped off the stack.
#! value than it produces.
over [ call ] [ 2drop ] ifte ; inline interpret-only
+: forever ( quot -- )
+ #! The code is evaluated in an infinite loop. Typically, a
+ #! continuation is used to escape the infinite loop.
+ #!
+ #! This combinator will not compile.
+ dup dip forever ; interpret-only
+
+! DEPRECATED
+
+: 2apply ( x y quot -- )
+ #! First applies the code to x, then to y.
+ #!
+ #! If the quotation compiles, this combinator compiles.
+ 2dup >r >r nip call r> r> call ; inline interpret-only
+
+: cleave ( x quot quot -- )
+ #! Executes each quotation, with x on top of the stack.
+ #!
+ #! If the quotation compiles, this combinator compiles.
+ >r over >r call r> r> call ; inline interpret-only
+
+: dip ( a [ b ] -- b a )
+ #! Call b as if b was not present on the stack.
+ #!
+ #! If the quotation compiles, this combinator compiles.
+ swap >r call r> ; inline interpret-only
+
+: 2dip ( a b [ c ] -- c a b )
+ #! Call c as if a and b were not present on the stack.
+ #!
+ #! If the quotation compiles, this combinator compiles.
+ -rot >r >r call r> r> ; inline interpret-only
+
+: interleave ( X quot -- )
+ #! Evaluate each element of the list with X on top of the
+ #! stack. When done, X is popped off the stack.
+ #!
+ #! To avoid unexpected results, each element of the list
+ #! must have stack effect ( X -- ).
+ #!
+ #! This combinator will not compile.
+ dup [
+ over [ unswons dip ] dip swap interleave
+ ] [
+ 2drop
+ ] ifte ; interpret-only
+
: while ( cond body -- )
#! Evaluate cond. If it leaves t on the stack, evaluate
#! body, and recurse.
] [
! Note that hex> will push f if there is an invalid
! hex literal
- [ succ dup 2 + ] dip substring hex> [ >char % ] when*
+ >r succ dup 2 + r> substring hex> [ >char % ] when*
] ifte ;
: url-decode-% ( index str -- index str )
- 2dup url-decode-hex [ 3 + ] dip ;
+ 2dup url-decode-hex >r 3 + r> ;
-: url-decode-+-or-other ( index str -- index str )
- CHAR: + CHAR: \s replace % [ succ ] dip ;
+: url-decode-+-or-other ( index str ch -- index str )
+ CHAR: + CHAR: \s replace % >r succ r> ;
: url-decode-iter ( index str -- )
2dup str-length >= [
USE: namespaces
USE: stack
-: +@ ( num var -- ) dup [ get + ] dip set ;
-: -@ ( num var -- ) dup [ get swap - ] dip set ;
-: *@ ( num var -- ) dup [ get * ] dip set ;
-: /@ ( num var -- ) dup [ get / ] dip set ;
+: +@ ( num var -- ) tuck get + put ;
+: -@ ( num var -- ) tuck get swap - put ;
+: *@ ( num var -- ) tuck get * put ;
+: /@ ( num var -- ) tuck get swap / put ;
: neg@ ( var -- ) dup get neg put ;
: pred@ ( var -- ) dup get pred put ;
: succ@ ( var -- ) dup get succ put ;
] ifte ;
: ^mag ( w abs arg -- magnitude )
- [ [ >rect swap ] dip swap fpow ] dip rot * fexp / ;
+ >r >r >rect swap r> swap fpow r> rot * fexp / ;
: ^theta ( w abs arg -- theta )
- [ [ >rect ] dip flog * swap ] dip * + ;
+ >r >r >rect r> flog * swap r> * + ;
: ^ ( z w -- z^w )
over real? over integer? and [
USE: stack
: quadratic-complete ( a b c -- a b c a b )
- [ 2dup ] dip -rot ;
+ >r 2dup r> -rot ;
: quadratic-d ( c a b -- sqrt[b^2 - 4*a*c] )
sq -rot 4 * * - sqrt ;
neg swap / 2 / ;
: quadratic-roots ( a b d -- alpha beta )
- 3dup - quadratic-root [ + quadratic-root ] dip ;
+ 3dup - quadratic-root >r + quadratic-root r> ;
: quadratic ( a b c -- alpha beta )
#! Finds both roots of the polynomial a*x^2 + b*x + c using
: lazy ( var [ a ] -- value )
#! If the value of the variable is f, set the value to the
#! result of evaluating [ a ].
- over get [ drop get ] [ dip dupd set ] ifte ;
+ over get [ drop get ] [ swap >r call dup r> set ] ifte ;
: alist> ( alist namespace -- )
#! Set each key in the alist to its value in the
: alist>namespace ( alist -- namespace )
<namespace> tuck alist> ;
-: object-path-traverse ( name object -- object )
+: traverse-path ( name object -- object )
dup has-namespace? [ get* ] [ 2drop f ] ifte ;
-: object-path-iter ( object list -- object )
- [
- uncons [ swap object-path-traverse ] dip
- object-path-iter
- ] when* ;
+: (object-path) ( object list -- object )
+ [ uncons >r swap traverse-path r> (object-path) ] when* ;
: object-path ( list -- object )
#! An object path is a list of strings. Each string is a
#! variable name in the object namespace at that level.
#! Returns f if any of the objects are not set.
- this swap object-path-iter ;
+ this swap (object-path) ;
: on ( var -- ) t put ;
: off ( var -- ) f put ;
: random-element-iter ( list index -- elem )
#! Used by random-element*. Do not call directly.
- [ unswons unswons ] dip ( list elem probability index )
+ >r unswons unswons r> ( list elem probability index )
swap - ( list elem index )
dup 0 <= [
drop nip
#! Returns a random subset of the given list of comma pairs.
#! The car of each pair is a probability, the cdr is the
#! item itself. Only the cdr of the comma pair is returned.
- dup [ [ [ ] ] dip car+ ] dip ( [ ] probabilitySum list )
- [
- [ 1 over random-int ] dip ( [ ] probabilitySum probability elem )
- uncons ( [ ] probabilitySum probability elema elemd )
- -rot ( [ ] probabilitySum elemd probability elema )
- > ( [ ] probabilitySum elemd boolean )
+ [,
+ [ car+ ] keep ( probabilitySum list )
[
- drop
- ] [
- -rot ( elemd [ ] probabilitySum )
- [ cons ] dip ( [ elemd ] probabilitySum )
- ] ifte
- ] each drop ;
+ >r 1 over random-int r> ( probabilitySum probability elem )
+ uncons ( probabilitySum probability elema elemd )
+ -rot ( probabilitySum elemd probability elema )
+ > ( probabilitySum elemd boolean )
+ [ drop ] [ , ] ifte
+ ] each drop
+ ,] ;
#! Apply a quotation to each character in the string, and
#! push a new string constructed from return values.
#! The quotation must have stack effect ( X -- X ).
- <% swap [ swap dup >r call % r> ] str-each drop %> ;
+ over str-length <sbuf> rot [
+ swap >r apply r> tuck sbuf-append
+ ] str-each nip sbuf>str ;
: split-next ( index string split -- next )
3dup index-of* dup -1 = [
: str/ ( str index -- str str )
#! Returns 2 strings, that when concatenated yield the
#! original string.
- 2dup str-tail [ str-head ] dip ;
+ 2dup str-tail >r str-head r> ;
: str// ( str index -- str str )
#! Returns 2 strings, that when concatenated yield the
#! original string, without the character at the given
#! index.
- 2dup succ str-tail [ str-head ] dip ;
+ 2dup succ str-tail >r str-head r> ;
: >title ( str -- str )
- 1 str/ [ >upper ] dip >lower cat2 ;
+ 1 str/ >r >upper r> >lower cat2 ;
: str-headcut ( str begin -- str str )
str-length str/ ;
+: =? ( x y z -- z/f )
+ #! Push z if x = y, otherwise f.
+ -rot = [ drop f ] unless ;
+
: str-head? ( str begin -- str )
#! If the string starts with begin, return the rest of the
#! string after begin. Otherwise, return f.
- 2dup str-length< [
- 2drop f
- ] [
- tuck str-headcut
- [ = ] dip f ?
- ] ifte ;
+ 2dup str-length< [ 2drop f ] [ tuck str-headcut =? ] ifte ;
: ?str-head ( str begin -- str ? )
dupd str-head? dup [ nip t ] [ drop f ] ifte ;
: str-tailcut ( str end -- str str )
- str-length [ dup str-length ] dip - str/ ;
+ str-length >r dup str-length r> - str/ swap ;
: str-tail? ( str end -- str )
#! If the string ends with end, return the start of the
#! string before end. Otherwise, return f.
- 2dup str-length< [
- 2drop f
- ] [
- tuck str-tailcut swap
- [ = ] dip f ?
- ] ifte ;
+ 2dup str-length< [ 2drop f ] [ tuck str-tailcut =? ] ifte ;
: ?str-tail ( str end -- str ? )
dupd str-tail? dup [ nip t ] [ drop f ] ifte ;
#! Execute the code, with each character of the string
#! pushed onto the stack.
over str-length [
- -rot 2dup [ [ str-nth ] dip call ] 2dip
+ -rot 2dup >r >r >r str-nth r> call r> r>
] times* 2drop ;
: str-sort ( list -- sorted )
--- /dev/null
+IN: scratchpad
+USE: namespaces
+USE: test
+USE: math
+
+5 "x" set
+
+[ 6 ] [ 1 "x" +@ "x" get ] unit-test
+[ 5 ] [ 1 "x" -@ "x" get ] unit-test
+[ 10 ] [ 2 "x" *@ "x" get ] unit-test
+[ 2 ] [ 5 "x" /@ "x" get ] unit-test
+[ -2 ] [ "x" neg@ "x" get ] unit-test
+[ -3 ] [ "x" pred@ "x" get ] unit-test
+[ -2 ] [ "x" succ@ "x" get ] unit-test
[ 10 | t ]
[ 20 | f ]
[ 30 | "monkey" ]
+ [ 24 | 1/2 ]
+ [ 13 | { "Hello" "Banana" } ]
] "random-pairs" set
+"random-pairs" get [ cdr ] map "random-values" set
+
[ f ]
[
"random-pairs" get
- random-element* [ t f "monkey" ] contains? not
+ random-element* "random-values" get contains? not
] unit-test
: check-random-int ( min max -- )
2dup random-int -rot between? assert ;
[ ] [ 100 [ -12 674 check-random-int ] times ] unit-test
+
+: check-random-subset ( expected pairs -- )
+ random-subset* [ over contains? ] all? nip ;
+
+[ t ] [
+ "random-values" get
+ "random-pairs" get
+ check-random-subset
+] unit-test
[ f ] [ [ 0 10 "hello" substring ] [ not ] catch ] unit-test
[ [ "hell" "o wo" "rld" ] ] [ 4 "hello world" split-n ] unit-test
+
+[ 4 ] [
+ 0 "There are Four Upper Case characters"
+ [ LETTER? [ succ ] when ] str-each
+] unit-test
+
+[ "Replacing+spaces+with+plus" ]
+[
+ "Replacing spaces with plus"
+ [ CHAR: \s CHAR: + replace ] str-map
+]
+unit-test
"math/complex"
"math/irrational"
"math/simpson"
+ "math/namespaces"
"httpd/url-encoding"
"httpd/html"
"httpd/httpd"
-rot 2dup >r >r >r vector-nth r> call r> r>
] times* 2drop ;
-: (vector-map-step) ( element code -- result code )
- dup >r call r> ;
-
-: (vector-map) ( code target element -- result code target )
- -rot >r (vector-map-step) r> ;
-
: vector-map ( vector code -- vector )
#! Applies code to each element of the vector, return a new
#! vector with the results. The code must have stack effect
#! ( obj -- obj ).
over vector-length <vector> rot [
- (vector-map) swapd tuck vector-push
+ swap >r apply r> tuck vector-push
] vector-each nip ;
: vector-and ( vector -- ? )
projects / factor.git / commitdiff