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