--- /dev/null
+IN: list-math
+USE: lists
+USE: math
+USE: stack
+USE: combinators
+USE: kernel
+USE: logic
+USE: math
+USE: stack
+
+: 2uncons ( list1 list2 -- car1 car2 cdr1 cdr2 )
+ uncons >r >r uncons r> swap r> ;
+
+: 2each-step ( list list quot -- cdr cdr )
+ >r 2uncons r> -rot 2slip ; inline interpret-only
+
+: 2each ( list list quot -- )
+ #! Apply the quotation to each pair of elements from the
+ #! two lists in turn. The quotation must have stack effect
+ #! ( x y -- ).
+ >r 2dup and [
+ r> dup >r 2each-step r> 2each
+ ] [
+ r> 3drop
+ ] ifte ;
+
+: 2map-step ( accum quot elt elt -- accum )
+ 2swap swap slip cons ;
+
+: <2map ( list list quot -- accum quot list list )
+ >r f -rot r> -rot ;
+
+: 2map ( list list quot -- list )
+ #! Apply the quotation to each pair of elements from the
+ #! two lists in turn, collecting the return value into a
+ #! new list. The quotation must have stack effect
+ #! ( x y -- z ).
+ <2map [ pick >r 2map-step r> ] 2each drop reverse ;
+
+: |+ ( list -- sum )
+ #! sum all elements in a list.
+ 0 swap [ + ] each ;
+
+: +| ( list list -- list )
+ [ + ] 2map ;
+
+: |* ( list -- sum )
+ #! multiply all elements in a list.
+ 1 swap [ * ] each ;
+
+: *| ( list list -- list )
+ [ * ] 2map ;
+
+: *|+ ( list list -- dot )
+ #! Dot product
+ *| |+ ;
+
+: average ( list -- avg )
+ dup |+ swap length / ;
] with-pixels ;
: mandel ( -- )
- 640 480 32 SDL_HWSURFACE SDL_SetVideoMode drop
+ 1280 1024 32 SDL_HWSURFACE SDL_FULLSCREEN bitor SDL_SetVideoMode drop
[
- 1 zoom-fact set
+ 3 zoom-fact set
-0.65 center set
50 nb-iter set
[ render ] time
\texttt{2dup ( x y -{}- x y x y )} Duplicate the top two stack elements. A frequent use for this word is when two values have to be compared using something like \texttt{=} or \texttt{<} before being passed to another word.
-\texttt{2swap ( x y z t -{}- z t x y )} Swap the top two stack elements.
+\texttt{3drop ( x y z -{}- )} Discard the top three stack elements.
+
+\texttt{3dup ( x y z -{}- x y z x y z )} Duplicate the top three stack elements.
You should try all these words out and become familiar with them. Push some numbers on the stack,
execute a shuffle word, and look at how the stack contents was changed using
Note the order of the shuffle word descriptions above. The ones at
the top are used most often because they are easy to understand. The
-more complex ones such as \texttt{rot} and \texttt{2swap} should be avoided unless absolutely necessary, because
+more complex ones such as \texttt{rot} and \texttt{2dup} should be avoided unless absolutely necessary, because
they make the flow of data in a word definition harder to understand.
If you find yourself using too many shuffle words, or you're writing
public class FactorInterpreter implements FactorObject, Runnable
{
- public static final String VERSION = "0.67";
+ public static final String VERSION = "0.68";
public static final Cons DEFAULT_USE = new Cons("builtins",
new Cons("syntax",new Cons("scratchpad",null)));
#! Looks up the key in an alist. Push the key/value pair.
#! Most of the time you want to use assoc not assoc*.
dup [
- 2dup car car = [
- nip car
- ] [
- cdr assoc*
- ] ifte
+ 2dup car car = [ nip car ] [ cdr assoc* ] ifte
] [
2drop f
] ifte ;
>r >r [ r> cons r> ] [ r> r> swapd cons ] ifte ; inline
: partition-step ( ret1 ret2 ref combinator car -- ret1 ret2 )
- >r 2swap r> -rot >r >r dup >r swap call r> swap r> r>
+ >r rot >r rot r> r> -rot >r >r dup >r swap call r> swap r> r>
partition-add ; inline
: partition-iter ( ret1 ret2 ref combinator list -- ret1 ret2 )
#! already contained in the list.
2dup contains? [ nip ] [ cons ] ifte ;
-: each-step ( list quot -- list quot )
+: (each) ( list quot -- list quot )
>r uncons r> tuck 2slip ; inline interpret-only
: each ( list quot -- )
#! Push each element of a proper list in turn, and apply a
#! quotation with effect ( X -- ) to each element.
- over [ each-step each ] [ 2drop ] ifte ;
+ over [ (each) each ] [ 2drop ] ifte ;
inline interpret-only
: reverse ( list -- list )
#! Push each element of a proper list in turn, and collect
#! return values of applying a quotation with effect
#! ( X -- Y ) to each element into a new list.
- over [ each-step rot >r map r> swons ] [ drop ] ifte ;
+ over [ (each) rot >r map r> swons ] [ drop ] ifte ;
inline interpret-only
-: 2uncons ( list1 list2 -- car1 car2 cdr1 cdr2 )
- uncons >r >r uncons r> swap r> ;
-
-: 2each-step ( list list quot -- cdr cdr )
- >r 2uncons r> -rot 2slip ; inline interpret-only
-
-: 2each ( list list quot -- )
- #! Apply the quotation to each pair of elements from the
- #! two lists in turn. The quotation must have stack effect
- #! ( x y -- ).
- >r 2dup and [
- r> dup >r 2each-step r> 2each
+: subset ( list quot -- list )
+ #! Applies a quotation with effect ( X -- ? ) to each
+ #! element of a list; all elements for which the quotation
+ #! returned a value other than f are collected in a new
+ #! list.
+ over [
+ over car >r (each)
+ rot >r subset r> [ r> swons ] [ r> drop ] ifte
] [
- r> 3drop
+ drop
] ifte ; inline interpret-only
-: 2map-step ( accum quot elt elt -- accum )
- 2swap swap slip cons ;
-
-: <2map ( list list quot -- accum quot list list )
- >r f -rot r> -rot ;
-
-: 2map ( list list quot -- list )
- #! Apply the quotation to each pair of elements from the
- #! two lists in turn, collecting the return value into a
- #! new list. The quotation must have stack effect
- #! ( x y -- z ).
- <2map [ pick >r 2map-step r> ] 2each drop reverse ;
- inline interpret-only
-
-: subset-add ( car pred accum -- accum )
- >r over >r call r> r> rot [ cons ] [ nip ] ifte ;
-
-: subset-iter ( accum list pred -- accum )
- over [
- >r unswons r> 2swap pick
- >r >r subset-add r> r> subset-iter
- ] [
- 2drop
- ] ifte ;
-
-: subset ( list pred -- list )
- #! Applies a quotation to each element of a list; all
- #! elements for which the quotation returned a value other
- #! than f are collected in a new list.
- #!
- #! In order to compile, the quotation must consume as many
- #! values as it produces.
- f -rot subset-iter reverse ; inline interpret-only
-
: remove ( obj list -- list )
#! Remove all occurrences of the object from the list.
[ dupd = not ] subset nip ;
+++ /dev/null
-! :folding=indent:collapseFolds=0:
-
-! $Id$
-!
-! Copyright (C) 2003, 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: math
-USE: lists
-USE: math
-USE: stack
-
-: |+ ( list -- sum )
- #! sum all elements in a list.
- 0 swap [ + ] each ;
-
-: +| ( list list -- list )
- [ + ] 2map ;
-
-: |* ( list -- sum )
- #! multiply all elements in a list.
- 1 swap [ * ] each ;
-
-: *| ( list list -- list )
- [ * ] 2map ;
-
-: *|+ ( list list -- dot )
- #! Dot product
- *| |+ ;
-
-: average ( list -- avg )
- dup |+ swap length / ;
: fib ( n -- nth fibonacci number )
! This is the naive implementation, for benchmarking purposes.
- dup 1 <= [
- drop 1
- ] [
- pred dup fib swap pred fib +
- ] ifte ;
+ dup 1 <= [ drop 1 ] [ pred dup fib swap pred fib + ] ifte ;
: fac ( n -- n! )
! This is the naive implementation, for benchmarking purposes.
: abs ( z -- abs )
#! Compute the complex absolute value.
- dup complex? [
- >rect mag2
- ] [
- dup 0 < [ neg ] when
- ] ifte ;
+ dup complex? [ >rect mag2 ] [ dup 0 < [ neg ] when ] ifte ;
: conjugate ( z -- z* )
>rect neg rect> ;
: -@ ( 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 ;
"/library/math/constants.factor" run-resource ! math
"/library/math/math.factor" run-resource ! math
"/library/math/pow.factor" run-resource ! math
-"/library/math/list-math.factor" run-resource ! math
!!! Development tools.
"/library/platform/jvm/processes.factor" run-resource ! processes
"/library/math/pow.factor" run-resource ! math
"/library/math/trig-hyp.factor" run-resource ! math
"/library/math/arc-trig-hyp.factor" run-resource ! math
-"/library/math/list-math.factor" run-resource ! math
!!! Development tools.
"/library/platform/jvm/processes.factor" run-resource ! processes
"/library/math/pow.factor"
"/library/math/trig-hyp.factor"
"/library/math/arc-trig-hyp.factor"
- "/library/math/list-math.factor"
"/library/platform/native/in-thread.factor"
"/library/platform/native/network.factor"
: 3drop ( x x x -- ) drop drop drop ;
: 2dup ( x y -- x y x y ) over over ;
: 3dup ( x y z -- x y z x y z ) pick pick pick ;
-: 2swap ( x y z t -- z t x y ) rot >r rot r> ;
: -rot ( x y z -- z x y ) rot rot ;
: dupd ( x y -- x x y ) >r dup r> ;
: swapd ( x y z -- y x z ) >r swap r> ;
: reveal ( word -- )
#! Add a new word to its vocabulary.
- "vocabularies" get [
- dup word-vocabulary over word-name 2list set-object-path
+ global [
+ "vocabularies" get [
+ dup word-vocabulary
+ over word-name
+ 2list set-object-path
+ ] bind
] bind ;
: create ( name vocab -- word )
[ 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
projects / factor.git / commitdiff