examples/ directory
Slava Pestov
parent
7df4ae98d7
commit
9f938842e3
|
|
@ -0,0 +1,60 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,269 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,33 @@
|
||||||
|
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
|
||||||
|
|
@ -0,0 +1,150 @@
|
||||||
|
! :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 ;
|
||||||
|
|
@ -0,0 +1,100 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,35 @@
|
||||||
|
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
|
||||||
|
|
@ -0,0 +1,79 @@
|
||||||
|
! :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
|
||||||
|
|
@ -0,0 +1,48 @@
|
||||||
|
! :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 ;
|
||||||
|
|
@ -0,0 +1,70 @@
|
||||||
|
! :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> * ;
|
||||||
Loading…
Reference in New Issue