+++ /dev/null
-! DeJong attractor renderer.
-! To run this code, start your interpreter like so:
-!
-! ./f -libraries:sdl=libSDL.so -libraries:sdl-gfx=libSDL_gfx.so
-!
-! Then, enter this at the interpreter prompt:
-!
-! "contrib/dejong.factor" run-file
-
-! For details on DeJong attractors, see
-! http://www.complexification.net/gallery/machines/peterdejong/
-
-IN: dejong
-
-USE: sdl
-USE: namespaces
-USE: math
-USE: stack
-
-SYMBOL: a
-SYMBOL: b
-SYMBOL: c
-SYMBOL: d
-
-: next-x ( x y -- x ) a get * sin swap b get * cos - ;
-: next-y ( x y -- y ) swap c get * sin swap d get * cos - ;
-
-: white ( -- rgb )
- HEX: ffffffff ;
-
-: pixel ( #{ x y } color -- )
- >r >r surface get r> >rect r> pixelColor ;
-
-: iterate-dejong ( x y -- x y )
- 2dup next-y >r next-x r> ;
-
-: scale-dejong ( x y -- x y )
- swap width get 4 / * width get 2 / + >fixnum
- swap height get 4 / * height get 2 / + >fixnum ;
-
-: draw-dejong ( x0 y0 iterations -- )
- [
- iterate-dejong 2dup scale-dejong rect> white pixel
- ] times 2drop ;
-
-: dejong ( -- )
- ! Fiddle with these four values!
- 1.4 a set
- -2.3 b set
- 2.4 c set
- -2.1 d set
-
- 640 480 32 SDL_HWSURFACE [
- [ 0 0 100000 draw-dejong ] with-surface
-
- <event> event-loop
- SDL_Quit
- ] with-screen ;
-
-dejong
+++ /dev/null
-USE: combinators
-USE: lists
-USE: math
-USE: namespaces
-USE: stack
-USE: test
-USE: vectors
-USE: words
-
-SYMBOL: exprs
-DEFER: infix
-: >e exprs get vector-push ;
-: e> exprs get vector-pop ;
-: e@ exprs get dup vector-empty? [ drop f ] [ vector-peek ] ifte ;
-: e, ( obj -- ) dup cons? [ [ e, ] each ] [ , ] ifte ;
-: end ( -- ) exprs get [ e, ] vector-each ;
-: >postfix ( op -- ) e@ word? [ e> e> -rot 3list ] when >e ;
-: token ( obj -- ) dup cons? [ infix ] when >postfix ;
-: (infix) ( list -- ) [ unswons token (infix) ] when* ;
-
-: infix ( list -- quot )
- #! Convert an infix expression (passed in as a list) to
- #! postfix.
- [, 10 <vector> exprs set (infix) end ,] ;
-
-[ [ ] ] [ [ ] infix ] unit-test
-[ [ 1 ] ] [ [ 1 ] infix ] unit-test
-[ [ 2 3 + ] ] [ [ 2 + 3 ] infix ] unit-test
-[ [ 2 3 * 4 + ] ] [ [ 2 * 3 + 4 ] infix ] unit-test
-[ [ 2 3 * 4 + 5 + ] ] [ [ 2 * 3 + 4 + 5 ] infix ] unit-test
-[ [ 2 3 * 4 + ] ] [ [ [ 2 * 3 ] + 4 ] infix ] unit-test
-[ [ 2 3 4 + * ] ] [ [ 2 * [ 3 + 4 ] ] infix ] unit-test
-[ [ 2 3 2 / 4 + * ] ] [ [ 2 * [ [ 3 / 2 ] + 4 ] ] infix ] unit-test
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 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: irc
-USE: combinators
-USE: errors
-USE: inspector
-USE: listener
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: parser
-USE: prettyprint
-USE: stack
-USE: stdio
-USE: streams
-USE: strings
-USE: words
-USE: unparser
-
-: irc-register ( -- )
- "USER " write
- "user" get write " " write
- "host" get write " " write
- "server" get write " " write
- "realname" get write " " print
-
- "NICK " write
- "nick" get print ;
-
-: irc-join ( channel -- )
- "JOIN " write print ;
-
-: irc-message ( message recepients -- )
- "PRIVMSG " write write " :" write print ;
-
-: irc-action ( message recepients -- )
- "ACTION " write write " :" write print ;
-
-: keep-datastack ( quot -- )
- datastack slip set-datastack drop ;
-
-: irc-stream-write ( string -- )
- dup "buf" get sbuf-append
- ends-with-newline? [
- "buf" get sbuf>str
- 0 "buf" get set-sbuf-length
- "\n" split [ dup f-or-"" [ drop ] [ "recepient" get irc-message ] ifte ] each
- ] when ;
-
-: <irc-stream> ( stream recepient -- stream )
- <stream> [
- "recepient" set
- "stdio" set
- 100 <sbuf> "buf" set
- [
- irc-stream-write
- ] "fwrite" set
- ] extend ;
-
-: irc-eval ( line -- )
- [
- [
- eval
- ] [
- default-error-handler
- ] catch
- ] keep-datastack drop ;
-
-: with-irc-stream ( recepient quot -- )
- [
- >r "stdio" get swap <irc-stream> "stdio" set r> call
- ] with-scope ;
-
-: irc-action-quot ( action -- quot )
- [
- [ "eval" swap [ irc-eval ] with-irc-stream ]
- [ "see" swap [ see terpri ] with-irc-stream ]
- [ "join" nip irc-join ]
- [ "quit" 2drop global [ "irc-quit-flag" on ] bind ]
- ] assoc [ [ 2drop ] ] unless* ;
-
-: irc-action-handler ( recepient message -- )
- " " split1 swap irc-action-quot call ;
-
-: irc-input ( line -- )
- #! Handle a line of IRC input.
- dup
- " PRIVMSG " split1 nip [
- ":" split1 dup [
- irc-action-handler
- ] [
- drop
- ] ifte
- ] when*
-
- global [ print ] bind ;
-
-: irc-quit-flag ( -- ? )
- global [ "irc-quit-flag" get ] bind ;
-
-: clear-irc-quit-flag ( -- ? )
- global [ "irc-quit-flag" off ] bind ;
-
-: irc-loop ( -- )
- irc-quit-flag [
- read [ irc-input irc-loop ] when*
- ] unless clear-irc-quit-flag ;
-
-: irc ( channels -- )
- irc-register
- "identify foobar" "NickServ" irc-message
- [ irc-join ] each
- irc-loop ;
-
-: irc-test
- "factorbot" "user" set
- "emu" "host" set
- "irc.freenode.net" "server" set
- "Factor" "realname" set
- "factorbot" "nick" set
- "irc.freenode.net" 6667 <client> [
- [ "#concatenative" ] irc
- ] with-stream ;
+++ /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 / ;
+++ /dev/null
-! Graphical mandelbrot fractal renderer.
-! To run this code, start your interpreter like so:
-!
-! ./f -library:sdl=libSDL.so -library:sdl-gfx=libSDL_gfx.so
-!
-! Then, enter this at the interpreter prompt:
-!
-! "contrib/mandel.factor" run-file
-
-IN: mandel
-
-USE: alien
-USE: combinators
-USE: errors
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: sdl
-USE: stack
-USE: vectors
-USE: prettyprint
-USE: stdio
-USE: test
-
-: scale 255 * >fixnum ;
-
-: scale-rgba ( r g b -- n )
- scale
- swap scale 8 shift bitor
- swap scale 16 shift bitor
- swap scale 24 shift bitor ;
-
-: sat 0.85 ;
-: val 0.85 ;
-
-: <color-map> ( nb-cols -- map )
- [,
- dup [
- 360 * over succ / 360 / sat val
- hsv>rgb 1.0 scale-rgba ,
- ] times*
- ,] list>vector nip ;
-
-: absq >rect swap sq swap sq + ;
-
-: iter ( c z nb-iter -- x )
- over absq 4 >= over 0 = or [
- nip nip
- ] [
- pred >r sq dupd + r> iter
- ] ifte ;
-
-: max-color 360 ;
-
-SYMBOL: zoom-fact
-SYMBOL: x-inc
-SYMBOL: y-inc
-SYMBOL: nb-iter
-SYMBOL: cols
-SYMBOL: center
-
-: init-mandel ( -- )
- width get 200000 zoom-fact get * / x-inc set
- height get 150000 zoom-fact get * / y-inc set
- nb-iter get max-color min <color-map> cols set ;
-
-: c ( #{ i j } -- c )
- >rect >r
- x-inc get * center get real x-inc get width get 2 / * - + >float
- r>
- y-inc get * center get imaginary y-inc get height get 2 / * - + >float
- rect> ;
-
-: render ( -- )
- init-mandel
- width get height get [
- c 0 nb-iter get iter dup 0 = [
- drop 0
- ] [
- cols get [ vector-length mod ] keep vector-nth
- ] ifte
- ] with-pixels ;
-
-: mandel ( -- )
- 640 480 32 SDL_HWSURFACE [
- [
- 0.8 zoom-fact set
- -0.65 center set
- 100 nb-iter set
- [ render ] time
- "Done." print flush
- ] with-surface
-
- <event> event-loop
- SDL_Quit
- ] with-screen ;
-
-mandel
+++ /dev/null
-! :folding=indent:collapseFolds=0:
-
-! $Id$
-!
-! Copyright (C) 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: combinators
-USE: math
-USE: stack
-
-: quadratic-complete ( a b c -- a b c a b )
- >r 2dup r> -rot ;
-
-: quadratic-d ( c a b -- sqrt[b^2 - 4*a*c] )
- sq -rot 4 * * - sqrt ;
-
-: quadratic-root ( x y -- -y/x/2 )
- neg swap / 2 / ;
-
-: quadratic-roots ( a b d -- alpha beta )
- 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
- #! the quadratic formula.
- quadratic-complete quadratic-d quadratic-roots ;
+++ /dev/null
-! :folding=indent:collapseFolds=0:
-
-! $Id$
-!
-! Copyright (C) 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: combinators
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: stack
-
-: multiplier ( n -- 2|4 )
- odd? 4 2 ? ;
-
-: (multipliers) ( list n -- list )
- dup 2 <= [
- drop
- ] [
- dup >r multiplier swons r> pred (multipliers)
- ] ifte ;
-
-: multipliers ( n -- list )
- #! The value n must be odd. Makes a list like [ 1 4 2 4 1 ]
- [ 1 ] swap (multipliers) 1 swons ;
-
-: x-values ( lower upper n -- list )
- #! The value n must be odd.
- pred >r over - r> dup succ count [
- >r 3dup r> swap / * +
- ] map >r 3drop r> ;
-
-: y-values ( lower upper n quot -- values )
- >r x-values r> map ;
-
-: (simpson) ( lower upper n quot -- value )
- over multipliers >r y-values r> *|+ ;
-
-: h ( lower upper n -- h )
- transp - swap pred / 3 / ;
-
-: simpson ( lower upper n quot -- value )
- #! Compute the integral between the lower and upper bound,
- #! using Simpson's method with n steps. The value of n must
- #! be odd. The quotation must have stack effect
- #! ( x -- f(x) ).
- >r 3dup r> (simpson) >r h r> * ;
projects / factor.git / commitdiff