--- /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
+! Currently the plugin doesn't handle GENERIC: and M:, so we
+! disable the parser. too many errors :sidekick.parser=none:
+IN: factoroids
+
+USE: combinators
+USE: errors
+USE: hashtables
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: oop
+USE: random
+USE: sdl
+USE: stack
+
+! Game objects
+GENERIC: draw ( -- )
+#! Draw the actor.
+
+GENERIC: tick ( -- ? )
+#! Return f if the actor should be removed.
+
+! Actor attributes
+SYMBOL: x
+SYMBOL: y
+SYMBOL: radius
+SYMBOL: len
+SYMBOL: dx
+SYMBOL: dy
+SYMBOL: color
+
+! The list of actors is divided into layers. Note that an
+! actor's tick method can only add actors to layers other than
+! the actor's layer. The player layer only has one actor.
+SYMBOL: player
+SYMBOL: enemies
+SYMBOL: player-shots
+SYMBOL: enemy-shots
+
+: player-actor ( -- actor )
+ player get car ;
+
+: y-in-screen? ( -- ? ) y get 0 height get between? ;
+: x-in-screen? ( -- ? ) x get 0 width get between? ;
+
+: in-screen? ( -- ? )
+ #! Is the current actor in the screen?
+ x-in-screen? y-in-screen? and ;
+
+: velocity ( -- )
+ #! Add velocity vector to current actor's position vector.
+ dx get x +@ dy get y +@ ;
+
+: actor-tick ( actor -- ? )
+ #! Default tick behavior of an actor. Move actor according
+ #! to velocity, and remove it if it is not in the screen.
+ #! Player's ship always returns t.
+ [
+ velocity
+ namespace player-actor = [ t ] [ in-screen? ] ifte
+ ] bind ;
+
+: screen-xy ( -- x y )
+ x get >fixnum y get >fixnum ;
+
+: actor-xy ( actor -- )
+ #! Copy actor's x/y co-ordinates to this namespace.
+ [ x get y get ] bind y set x set ;
+
+! The player's ship
+TRAITS: ship
+M: ship draw ( -- )
+ [
+ surface get screen-xy radius get color get
+ filledCircleColor
+ ] bind ;M
+
+M: ship tick ( -- ) actor-tick ;M
+
+! Projectiles
+TRAITS: plasma
+M: plasma draw ( -- )
+ [
+ surface get screen-xy dup len get + color get
+ vlineColor
+ ] bind ;M
+
+M: plasma tick ( -- ) actor-tick ;M
+
+: make-plasma ( actor dy -- plasma )
+ <plasma> [
+ dy set
+ 0 dx set
+ actor-xy
+ blue color set
+ 10 len set
+ ] extend ;
+
+: player-fire ( -- )
+ player-actor -6 make-plasma player-shots cons@ ;
+
+: enemy-fire ( actor -- )
+ 5 make-plasma enemy-shots cons@ ;
+
+! Background of stars
+TRAITS: particle
+
+M: particle draw ( -- )
+ [ surface get screen-xy color get pixelColor ] bind ;M
+
+: wrap ( -- )
+ #! If current actor has gone beyond screen bounds, move it
+ #! back.
+ width get x rem@ height get y rem@ ;
+
+M: particle tick ( -- )
+ [ velocity wrap t ] bind ;M
+
+SYMBOL: stars
+: star-count 100 ;
+
+: random-x 0 width get random-int ;
+: random-y 0 height get random-int ;
+: random-byte 0 255 random-int ;
+: random-color random-byte random-byte random-byte 255 rgba ;
+
+: random-star ( -- star )
+ <particle> [
+ random-x x set
+ random-y y set
+ random-color color set
+ 2 4 random-int dy set
+ 0 dx set
+ ] extend ;
+
+: init-stars ( -- )
+ [ ] star-count [ random-star swons ] times stars set ;
+
+: draw-stars ( -- )
+ stars get [ draw ] each ;
+
+: tick-stars ( -- )
+ stars get [ tick drop ] each ;
+
+! Enemies
+: enemy-chance 50 ;
+
+TRAITS: enemy
+M: enemy draw ( -- )
+ [
+ surface get screen-xy radius get color get
+ filledCircleColor
+ ] bind ;M
+
+: attack-chance 30 ;
+
+: attack ( -- ) attack-chance chance [ enemy-fire ] when ;
+
+SYMBOL: wiggle-x
+
+: wiggle ( -- )
+ #! Wiggle from left to right.
+ -3 3 random-int wiggle-x +@
+ wiggle-x get sgn dx set ;
+
+M: enemy tick ( -- )
+ dup attack [ wiggle velocity y-in-screen? ] bind ;M
+
+: spawn-enemy ( -- )
+ <enemy> [
+ 10 y set
+ random-x x set
+ red color set
+ 0 wiggle-x set
+ 0 dx set
+ 1 dy set
+ 10 radius set
+ ] extend ;
+
+: spawn-enemies ( -- )
+ enemy-chance chance [ spawn-enemy enemies cons@ ] when ;
+
+! Event handling
+SYMBOL: event
+
+: mouse-motion-event ( event -- )
+ motion-event-x player-actor [ x set ] bind ;
+
+: mouse-down-event ( event -- )
+ drop player-fire ;
+
+: handle-event ( event -- ? )
+ #! Return if we should continue or stop.
+ [
+ [ event-type SDL_MOUSEBUTTONDOWN = ] [ mouse-down-event t ]
+ [ event-type SDL_MOUSEMOTION = ] [ mouse-motion-event t ]
+ [ event-type SDL_QUIT = ] [ drop f ]
+ [ drop t ] [ drop t ]
+ ] cond ;
+
+: check-event ( -- ? )
+ #! Check if there is a pending event.
+ #! Return if we should continue or stop.
+ event get dup SDL_PollEvent [
+ handle-event [ check-event ] [ f ] ifte
+ ] [
+ drop t
+ ] ifte ;
+
+! Game loop
+: init-player ( -- )
+ <ship> [
+ height get 50 - y set
+ width get 2 /i x set
+ white color set
+ 10 radius set
+ 0 dx set
+ 0 dy set
+ ] extend unit player set ;
+
+: init-events ( -- ) <event> event set ;
+
+: init-game ( -- )
+ #! Init game objects.
+ init-player init-stars init-events ;
+
+: each-layer ( quot -- )
+ #! Apply quotation to each layer.
+ [ enemies enemy-shots player player-shots ] swap each ;
+
+: draw-layer ( layer -- )
+ get [ draw ] each ;
+
+: draw-actors ( -- )
+ [ draw-layer ] each-layer ;
+
+: tick-layer ( layer -- )
+ dup get [ tick ] subset put ;
+
+: tick-actors ( -- )
+ #! Advance game state by one frame.
+ [ tick-layer ] each-layer ;
+
+: render ( -- )
+ #! Draw the scene.
+ [
+ black clear-surface
+ draw-stars
+ draw-actors
+ ] with-surface ;
+
+: advance ( -- )
+ #! Advance game state by one frame.
+ tick-actors tick-stars spawn-enemies ;
+
+: game-loop ( -- )
+ #! Render, advance game state, repeat.
+ render advance check-event [ game-loop ] when ;
+
+: factoroids ( -- )
+ #! Main word.
+ 640 480 32 SDL_HWSURFACE [
+ "Factoroids" "Factoroids" SDL_WM_SetCaption
+ init-game game-loop
+ ] with-screen ;
+
+factoroids
--- /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
+! 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
+IN: scratchpad
+USE: hashtables
+USE: namespaces
+USE: oop
+USE: stack
+USE: test
+
+TRAITS: test-traits
+
+[ t ] [ <test-traits> test-traits? ] unit-test
+[ f ] [ "hello" test-traits? ] unit-test
+[ f ] [ <namespace> test-traits? ] unit-test
+
+GENERIC: foo
+
+M: test-traits foo drop 12 ;M
+
+TRAITS: another-test
+
+M: another-test foo drop 13 ;M
+
+[ 12 ] [ <test-traits> foo ] unit-test
+[ 13 ] [ <another-test> foo ] unit-test
+
+TRAITS: quux
+
+M: quux foo "foo" swap hash ;M
+
+[
+ "Hi"
+] [
+ <quux> [
+ "Hi" "foo" set
+ ] extend foo
+] unit-test
--- /dev/null
+! :sidekick.parser=none:
+IN: oop
+
+USE: combinators
+USE: errors
+USE: hashtables
+USE: kernel
+USE: lists
+USE: namespaces
+USE: parser
+USE: stack
+USE: strings
+USE: words
+
+SYMBOL: traits
+
+: traits-map ( word -- hash )
+ #! The method map word property maps selector words to
+ #! definitions.
+ "traits-map" word-property ;
+
+: object-map ( obj -- hash )
+ dup has-namespace? [ traits swap get* ] [ drop f ] ifte ;
+
+: init-traits-map ( word -- )
+ <namespace> "traits-map" set-word-property ;
+
+: no-method
+ "No applicable method." throw ;
+
+: method ( traits selector -- quot )
+ #! Execute the method with the traits object on the stack.
+ over object-map hash* [ cdr ] [ [ no-method ] ] ifte* ;
+
+: constructor-word ( word -- word )
+ word-name "<" swap ">" cat3 "in" get create ;
+
+: define-constructor ( word -- )
+ #! <foo> where foo is a traits type creates a new instance
+ #! of foo.
+ [ constructor-word [ <namespace> ] ] keep
+ traits-map [ traits pick set* ] cons append
+ define-compound ;
+
+: predicate-word ( word -- word )
+ word-name "?" cat2 "in" get create ;
+
+: define-predicate ( word -- )
+ #! foo? where foo is a traits type tests if the top of stack
+ #! is of this type.
+ dup predicate-word swap
+ [ object-map ] swap traits-map [ eq? ] cons append
+ define-compound ;
+
+: TRAITS:
+ #! TRAITS: foo creates a new traits type. Instances can be
+ #! created with <foo>, and tested with foo?.
+ CREATE
+ dup define-symbol
+ dup init-traits-map
+ dup define-constructor
+ define-predicate ; parsing
+
+: GENERIC:
+ #! GENERIC: bar creates a generic word bar that calls the
+ #! bar method on the traits object, with the traits object
+ #! on the stack.
+ CREATE
+ dup unit [ car method call ] cons
+ define-compound ; parsing
+
+: M:
+ #! M: foo bar begins a definition of the bar generic word
+ #! specialized to the foo type.
+ scan-word scan-word f ; parsing
+
+: ;M
+ #! ;M ends a method definition.
+ reverse transp traits-map set* ; parsing
--- /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