Merge remote-tracking branch 'origin/master' into modern-harvey2
Doug Coleman
commit
25bf216bf4
|
|
@ -117,6 +117,10 @@ HELP: log
|
||||||
{ $values { "x" number } { "y" number } }
|
{ $values { "x" number } { "y" number } }
|
||||||
{ $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
|
{ $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
|
||||||
|
|
||||||
|
HELP: logn
|
||||||
|
{ $values { "x" number } { "n" number } { "y" number } }
|
||||||
|
{ $description "Finds the base " { $snippet "n" } " logarithm of " { $snippet "x" } "." } ;
|
||||||
|
|
||||||
HELP: log1+
|
HELP: log1+
|
||||||
{ $values { "x" number } { "y" number } }
|
{ $values { "x" number } { "y" number } }
|
||||||
{ $description "Takes the natural logarithm of " { $snippet "1 + x" } ". Outputs negative infinity if " { $snippet "1 + x" } " is zero. This word may be more accurate than " { $snippet "1 + log" } " for very small values of " { $snippet "x" } "." } ;
|
{ $description "Takes the natural logarithm of " { $snippet "1 + x" } ". Outputs negative infinity if " { $snippet "1 + x" } " is zero. This word may be more accurate than " { $snippet "1 + log" } " for very small values of " { $snippet "x" } "." } ;
|
||||||
|
|
|
||||||
|
|
@ -69,6 +69,10 @@ IN: math.functions.tests
|
||||||
{ 0.0 } [ 1.0 log ] unit-test
|
{ 0.0 } [ 1.0 log ] unit-test
|
||||||
{ 1.0 } [ e log ] unit-test
|
{ 1.0 } [ e log ] unit-test
|
||||||
|
|
||||||
|
{ 0.0 } [ 1 e logn ] unit-test
|
||||||
|
{ 0.0 } [ 1.0 e logn ] unit-test
|
||||||
|
{ 1.0 } [ e e logn ] unit-test
|
||||||
|
|
||||||
CONSTANT: log-factorial-1000 0x1.71820d04e2eb6p12
|
CONSTANT: log-factorial-1000 0x1.71820d04e2eb6p12
|
||||||
CONSTANT: log10-factorial-1000 0x1.40f3593ed6f8ep11
|
CONSTANT: log10-factorial-1000 0x1.40f3593ed6f8ep11
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -196,6 +196,8 @@ M: real log >float log ; inline
|
||||||
|
|
||||||
M: complex log >polar [ flog ] dip rect> ; inline
|
M: complex log >polar [ flog ] dip rect> ; inline
|
||||||
|
|
||||||
|
: logn ( x n -- y ) [ log ] bi@ / ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: most-negative-finite-float ( -- x )
|
: most-negative-finite-float ( -- x )
|
||||||
|
|
|
||||||
|
|
@ -32,7 +32,7 @@ CONSTANT: elevator-padding 4
|
||||||
|
|
||||||
: elevator-length ( slider -- n )
|
: elevator-length ( slider -- n )
|
||||||
[ elevator>> dim>> ] [ orientation>> ] bi v.
|
[ elevator>> dim>> ] [ orientation>> ] bi v.
|
||||||
elevator-padding 2 * - ;
|
elevator-padding 2 * [-] ;
|
||||||
|
|
||||||
CONSTANT: min-thumb-dim 30
|
CONSTANT: min-thumb-dim 30
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,227 +0,0 @@
|
||||||
|
|
||||||
USING: accessors arrays combinators combinators.short-circuit
|
|
||||||
fry kernel locals math math.intervals math.vectors multi-methods
|
|
||||||
sequences ;
|
|
||||||
IN: flatland
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
! Two dimensional world protocol
|
|
||||||
|
|
||||||
MULTI-GENERIC: x ( obj -- x )
|
|
||||||
MULTI-GENERIC: y ( obj -- y )
|
|
||||||
|
|
||||||
MULTI-GENERIC: (x!) ( x obj -- )
|
|
||||||
MULTI-GENERIC: (y!) ( y obj -- )
|
|
||||||
|
|
||||||
: x! ( obj x -- obj ) over (x!) ;
|
|
||||||
: y! ( obj y -- obj ) over (y!) ;
|
|
||||||
|
|
||||||
MULTI-GENERIC: width ( obj -- width )
|
|
||||||
MULTI-GENERIC: height ( obj -- height )
|
|
||||||
|
|
||||||
MULTI-GENERIC: (width!) ( width obj -- )
|
|
||||||
MULTI-GENERIC: (height!) ( height obj -- )
|
|
||||||
|
|
||||||
: width! ( obj width -- obj ) over (width!) ;
|
|
||||||
: height! ( obj height -- obj ) over (width!) ;
|
|
||||||
|
|
||||||
! Predicates on relative placement
|
|
||||||
|
|
||||||
MULTI-GENERIC: to-the-left-of? ( obj obj -- ? )
|
|
||||||
MULTI-GENERIC: to-the-right-of? ( obj obj -- ? )
|
|
||||||
|
|
||||||
MULTI-GENERIC: below? ( obj obj -- ? )
|
|
||||||
MULTI-GENERIC: above? ( obj obj -- ? )
|
|
||||||
|
|
||||||
MULTI-GENERIC: in-between-horizontally? ( obj obj -- ? )
|
|
||||||
|
|
||||||
MULTI-GENERIC: horizontal-interval ( obj -- interval )
|
|
||||||
|
|
||||||
MULTI-GENERIC: move-to ( obj obj -- )
|
|
||||||
|
|
||||||
MULTI-GENERIC: move-by ( obj delta -- )
|
|
||||||
|
|
||||||
MULTI-GENERIC: move-left-by ( obj obj -- )
|
|
||||||
MULTI-GENERIC: move-right-by ( obj obj -- )
|
|
||||||
|
|
||||||
MULTI-GENERIC: left ( obj -- left )
|
|
||||||
MULTI-GENERIC: right ( obj -- right )
|
|
||||||
MULTI-GENERIC: bottom ( obj -- bottom )
|
|
||||||
MULTI-GENERIC: top ( obj -- top )
|
|
||||||
|
|
||||||
MULTI-GENERIC: distance ( a b -- c )
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
! Some of the above methods work on two element sequences.
|
|
||||||
! A two element sequence may represent a point in space or describe
|
|
||||||
! width and height.
|
|
||||||
|
|
||||||
METHOD: x { sequence } first ;
|
|
||||||
METHOD: y { sequence } second ;
|
|
||||||
|
|
||||||
METHOD: (x!) { number sequence } set-first ;
|
|
||||||
METHOD: (y!) { number sequence } set-second ;
|
|
||||||
|
|
||||||
METHOD: width { sequence } first ;
|
|
||||||
METHOD: height { sequence } second ;
|
|
||||||
|
|
||||||
: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
|
|
||||||
: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
|
|
||||||
|
|
||||||
METHOD: move-to { sequence sequence } [ x x! ] [ y y! ] bi drop ;
|
|
||||||
METHOD: move-by { sequence sequence } dupd v+ [ x x! ] [ y y! ] bi drop ;
|
|
||||||
|
|
||||||
METHOD: move-left-by { sequence number } '[ _ - ] changed-x ;
|
|
||||||
METHOD: move-right-by { sequence number } '[ _ + ] changed-x ;
|
|
||||||
|
|
||||||
! METHOD: move-left-by { sequence number } neg 0 2array move-by ;
|
|
||||||
! METHOD: move-right-by { sequence number } 0 2array move-by ;
|
|
||||||
|
|
||||||
! METHOD:: move-left-by { SEQ:sequence X:number -- )
|
|
||||||
! SEQ { X 0 } { -1 0 } v* move-by ;
|
|
||||||
|
|
||||||
METHOD: distance { sequence sequence } v- norm ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
! A class for objects with a position
|
|
||||||
|
|
||||||
TUPLE: pos pos ;
|
|
||||||
|
|
||||||
METHOD: x { pos } pos>> first ;
|
|
||||||
METHOD: y { pos } pos>> second ;
|
|
||||||
|
|
||||||
METHOD: (x!) { number pos } pos>> set-first ;
|
|
||||||
METHOD: (y!) { number pos } pos>> set-second ;
|
|
||||||
|
|
||||||
METHOD: to-the-left-of? { pos number } [ x ] dip < ;
|
|
||||||
METHOD: to-the-right-of? { pos number } [ x ] dip > ;
|
|
||||||
|
|
||||||
METHOD: move-left-by { pos number } [ pos>> ] dip move-left-by ;
|
|
||||||
METHOD: move-right-by { pos number } [ pos>> ] dip move-right-by ;
|
|
||||||
|
|
||||||
METHOD: above? { pos number } [ y ] dip > ;
|
|
||||||
METHOD: below? { pos number } [ y ] dip < ;
|
|
||||||
|
|
||||||
METHOD: move-by { pos sequence } '[ _ v+ ] change-pos drop ;
|
|
||||||
|
|
||||||
METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
! A class for objects with velocity. It inherits from pos. Hey, if
|
|
||||||
! it's moving it has a position right? Unless it's some alternate universe...
|
|
||||||
|
|
||||||
TUPLE: vel < pos vel ;
|
|
||||||
|
|
||||||
: moving-up? ( obj -- ? ) vel>> y 0 > ;
|
|
||||||
: moving-down? ( obj -- ? ) vel>> y 0 < ;
|
|
||||||
|
|
||||||
: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
|
|
||||||
: move-for ( vel time -- ) dupd step-size move-by ;
|
|
||||||
|
|
||||||
: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
! The 'pos' slot indicates the lower left hand corner of the
|
|
||||||
! rectangle. The 'dim' is holds the width and height.
|
|
||||||
|
|
||||||
TUPLE: rectangle < pos dim ;
|
|
||||||
|
|
||||||
METHOD: width { rectangle } dim>> first ;
|
|
||||||
METHOD: height { rectangle } dim>> second ;
|
|
||||||
|
|
||||||
METHOD: left { rectangle } x ;
|
|
||||||
METHOD: right { rectangle } [ x ] [ width ] bi + ;
|
|
||||||
METHOD: bottom { rectangle } y ;
|
|
||||||
METHOD: top { rectangle } [ y ] [ height ] bi + ;
|
|
||||||
|
|
||||||
: bottom-left ( rectangle -- pos ) pos>> ;
|
|
||||||
|
|
||||||
: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
|
|
||||||
: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
|
|
||||||
|
|
||||||
: center ( rectangle -- seq ) [ center-x ] [ center-y ] bi 2array ;
|
|
||||||
|
|
||||||
METHOD: to-the-left-of? { pos rectangle } [ x ] [ left ] bi* < ;
|
|
||||||
METHOD: to-the-right-of? { pos rectangle } [ x ] [ right ] bi* > ;
|
|
||||||
|
|
||||||
METHOD: below? { pos rectangle } [ y ] [ bottom ] bi* < ;
|
|
||||||
METHOD: above? { pos rectangle } [ y ] [ top ] bi* > ;
|
|
||||||
|
|
||||||
METHOD: horizontal-interval { rectangle }
|
|
||||||
[ left ] [ right ] bi [a,b] ;
|
|
||||||
|
|
||||||
METHOD: in-between-horizontally? { pos rectangle }
|
|
||||||
[ x ] [ horizontal-interval ] bi* interval-contains? ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
TUPLE: extent left right bottom top ;
|
|
||||||
|
|
||||||
METHOD: left { extent } left>> ;
|
|
||||||
METHOD: right { extent } right>> ;
|
|
||||||
METHOD: bottom { extent } bottom>> ;
|
|
||||||
METHOD: top { extent } top>> ;
|
|
||||||
|
|
||||||
METHOD: width { extent } [ right>> ] [ left>> ] bi - ;
|
|
||||||
METHOD: height { extent } [ top>> ] [ bottom>> ] bi - ;
|
|
||||||
|
|
||||||
! METHOD: to-extent ( rectangle -- extent )
|
|
||||||
! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave extent boa ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
METHOD: to-the-left-of? { sequence rectangle } [ x ] [ left ] bi* < ;
|
|
||||||
METHOD: to-the-right-of? { sequence rectangle } [ x ] [ right ] bi* > ;
|
|
||||||
|
|
||||||
METHOD: below? { sequence rectangle } [ y ] [ bottom ] bi* < ;
|
|
||||||
METHOD: above? { sequence rectangle } [ y ] [ top ] bi* > ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
! Some support for the' 'rect' class from math.geometry.rect'
|
|
||||||
|
|
||||||
! METHOD: width ( rect -- width ) dim>> first ;
|
|
||||||
! METHOD: height ( rect -- height ) dim>> second ;
|
|
||||||
|
|
||||||
! METHOD: left ( rect -- left ) loc>> x
|
|
||||||
! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
|
|
||||||
|
|
||||||
! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
|
|
||||||
! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
:: wrap ( POINT RECT -- POINT )
|
|
||||||
{
|
|
||||||
{ [ POINT RECT to-the-left-of? ] [ RECT right ] }
|
|
||||||
{ [ POINT RECT to-the-right-of? ] [ RECT left ] }
|
|
||||||
{ [ t ] [ POINT x ] }
|
|
||||||
}
|
|
||||||
cond
|
|
||||||
|
|
||||||
{
|
|
||||||
{ [ POINT RECT below? ] [ RECT top ] }
|
|
||||||
{ [ POINT RECT above? ] [ RECT bottom ] }
|
|
||||||
{ [ t ] [ POINT y ] }
|
|
||||||
}
|
|
||||||
cond
|
|
||||||
|
|
||||||
2array ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
MULTI-GENERIC: within? ( a b -- ? )
|
|
||||||
|
|
||||||
METHOD: within? { pos rectangle }
|
|
||||||
{
|
|
||||||
[ left to-the-right-of? ]
|
|
||||||
[ right to-the-left-of? ]
|
|
||||||
[ bottom above? ]
|
|
||||||
[ top below? ]
|
|
||||||
}
|
|
||||||
2&& ;
|
|
||||||
|
|
@ -1 +1,2 @@
|
||||||
demos
|
demos
|
||||||
|
games
|
||||||
|
|
|
||||||
|
|
@ -1,135 +1,166 @@
|
||||||
USING: accessors alien.c-types alien.data arrays calendar colors
|
USING: accessors arrays calendar colors.constants
|
||||||
combinators combinators.short-circuit flatland generalizations
|
combinators.short-circuit fonts fry kernel literals locals math
|
||||||
grouping kernel locals math math.intervals math.order
|
math.order math.ranges math.vectors namespaces opengl random
|
||||||
math.rectangles math.vectors namespaces opengl opengl.gl
|
sequences timers ui ui.commands ui.gadgets ui.gadgets.worlds
|
||||||
opengl.glu processing.shapes sequences sequences.generalizations
|
ui.gestures ui.pens.solid ui.render ui.text ;
|
||||||
shuffle threads ui ui.gadgets ui.gestures ui.render ;
|
|
||||||
IN: pong
|
IN: pong
|
||||||
|
|
||||||
! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
|
CONSTANT: BOUNCE 6/5
|
||||||
!
|
CONSTANT: MAX-SPEED 6
|
||||||
! Which was based on this Nodebox version: http://billmill.org/pong.html
|
CONSTANT: BALL-SIZE 10
|
||||||
! by Bill Mill.
|
CONSTANT: BALL-DIM ${ BALL-SIZE BALL-SIZE }
|
||||||
|
CONSTANT: PADDLE-SIZE 80
|
||||||
|
CONSTANT: PADDLE-DIM ${ PADDLE-SIZE 10 }
|
||||||
|
CONSTANT: FONT $[
|
||||||
|
monospace-font
|
||||||
|
t >>bold?
|
||||||
|
COLOR: red >>foreground
|
||||||
|
COLOR: gray95 >>background
|
||||||
|
]
|
||||||
|
|
||||||
: clamp-to-interval ( x interval -- x )
|
TUPLE: ball pos vel ;
|
||||||
[ from>> first ] [ to>> first ] bi clamp ;
|
|
||||||
|
|
||||||
TUPLE: play-field < rectangle ;
|
TUPLE: pong-gadget < gadget timer ball player computer game-over? ;
|
||||||
|
|
||||||
TUPLE: paddle < rectangle ;
|
: initial-state ( gadget -- gadget )
|
||||||
|
|
||||||
TUPLE: computer < paddle { speed initial: 10 } ;
|
|
||||||
|
|
||||||
: computer-move-left ( computer -- ) dup speed>> move-left-by ;
|
|
||||||
|
|
||||||
: computer-move-right ( computer -- ) dup speed>> move-right-by ;
|
|
||||||
|
|
||||||
TUPLE: ball < vel
|
|
||||||
{ diameter initial: 20 }
|
|
||||||
{ bounciness initial: 1.2 }
|
|
||||||
{ max-speed initial: 10 } ;
|
|
||||||
|
|
||||||
: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
|
|
||||||
|
|
||||||
: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
|
|
||||||
|
|
||||||
: in-bounds? ( ball field -- ? )
|
|
||||||
{
|
|
||||||
[ above-lower-bound? ]
|
|
||||||
[ below-upper-bound? ]
|
|
||||||
} 2&& ;
|
|
||||||
|
|
||||||
:: bounce-change-vertical-velocity ( BALL -- )
|
|
||||||
BALL vel>> y neg
|
|
||||||
BALL bounciness>> *
|
|
||||||
BALL max-speed>> min
|
|
||||||
BALL vel>> (y!) ;
|
|
||||||
|
|
||||||
:: bounce-off-paddle ( BALL PADDLE -- )
|
|
||||||
BALL bounce-change-vertical-velocity
|
|
||||||
BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
|
|
||||||
PADDLE top BALL pos>> (y!) ;
|
|
||||||
|
|
||||||
: mouse-x ( -- x ) hand-loc get first ;
|
|
||||||
|
|
||||||
:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
|
|
||||||
PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
|
|
||||||
|
|
||||||
:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
|
|
||||||
mouse-x
|
|
||||||
PADDLE PLAY-FIELD valid-paddle-interval
|
|
||||||
clamp-to-interval
|
|
||||||
PADDLE pos>> (x!) ;
|
|
||||||
|
|
||||||
! Protocol for drawing PONG objects
|
|
||||||
|
|
||||||
GENERIC: draw ( obj -- )
|
|
||||||
|
|
||||||
M: paddle draw [ bottom-left ] [ dim>> ] bi draw-rectangle ;
|
|
||||||
|
|
||||||
M: ball draw [ pos>> ] [ diameter>> 2 / ] bi draw-circle ;
|
|
||||||
|
|
||||||
TUPLE: pong-gadget < gadget paused field ball player computer ;
|
|
||||||
|
|
||||||
: pong ( -- gadget )
|
|
||||||
pong-gadget new
|
|
||||||
T{ play-field { pos { 0 0 } } { dim { 400 400 } } } clone >>field
|
|
||||||
T{ ball { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
|
T{ ball { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
|
||||||
T{ paddle { pos { 200 396 } } { dim { 75 4 } } } clone >>player
|
200 >>player
|
||||||
T{ computer { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
|
200 >>computer
|
||||||
|
f >>game-over? ;
|
||||||
|
|
||||||
M: pong-gadget pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
|
DEFER: on-tick
|
||||||
|
|
||||||
M: pong-gadget ungraft* ( <pong> -- ) t >>paused drop ;
|
: <pong-gadget> ( -- gadget )
|
||||||
|
pong-gadget new initial-state
|
||||||
|
COLOR: gray95 <solid> >>interior
|
||||||
|
dup '[ _ on-tick ] f 16 milliseconds <timer> >>timer ;
|
||||||
|
|
||||||
|
M: pong-gadget pref-dim* drop { 400 400 } ;
|
||||||
|
|
||||||
|
M: pong-gadget ungraft*
|
||||||
|
[ timer>> stop-timer ] [ call-next-method ] bi ;
|
||||||
|
|
||||||
M:: pong-gadget draw-gadget* ( PONG -- )
|
M:: pong-gadget draw-gadget* ( PONG -- )
|
||||||
PONG computer>> draw
|
COLOR: gray80 gl-color
|
||||||
PONG player>> draw
|
15 390 20 <range> [
|
||||||
PONG ball>> draw ;
|
197 2array { 10 6 } gl-fill-rect
|
||||||
|
] each
|
||||||
|
|
||||||
|
COLOR: black gl-color
|
||||||
|
{ 0 0 } { 10 400 } gl-fill-rect
|
||||||
|
{ 390 0 } { 10 400 } gl-fill-rect
|
||||||
|
|
||||||
|
PONG computer>> 0 2array PADDLE-DIM gl-fill-rect
|
||||||
|
PONG player>> 390 2array PADDLE-DIM gl-fill-rect
|
||||||
|
PONG ball>> pos>> BALL-DIM gl-fill-rect
|
||||||
|
|
||||||
|
PONG game-over?>> [
|
||||||
|
FONT 48 >>size
|
||||||
|
PONG ball>> pos>> second 200 <
|
||||||
|
"YOU WIN!" "YOU LOSE!" ?
|
||||||
|
[ text-width 390 swap - 2 / 100 2array ]
|
||||||
|
[ '[ _ _ draw-text ] with-translation ] 2bi
|
||||||
|
] [
|
||||||
|
PONG timer>> thread>> [
|
||||||
|
FONT 24 >>size
|
||||||
|
{ " N - New Game" "SPACE - Pause" }
|
||||||
|
[ text-width 390 swap - 2 / 100 2array ]
|
||||||
|
[ '[ _ _ draw-text ] with-translation ] 2bi
|
||||||
|
] unless
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
:: move-player ( GADGET -- )
|
||||||
|
hand-loc get first PADDLE-SIZE 2 / -
|
||||||
|
10 390 PADDLE-SIZE - clamp GADGET player<< ;
|
||||||
|
|
||||||
|
:: move-ball ( GADGET -- )
|
||||||
|
GADGET ball>> :> BALL
|
||||||
|
|
||||||
|
! minimum movement to hit wall or paddle
|
||||||
|
BALL vel>> first dup 0 > 380 10 ?
|
||||||
|
BALL pos>> first - swap / 1 min
|
||||||
|
BALL vel>> second dup 0 > 380 10 ?
|
||||||
|
BALL pos>> second - swap / 1 min min :> movement
|
||||||
|
|
||||||
|
movement 0 > [ movement throw ] unless
|
||||||
|
BALL pos>> BALL vel>> movement v*n v+ BALL pos<< ;
|
||||||
|
|
||||||
|
: move-computer-by ( GADGET N -- )
|
||||||
|
'[ _ + 10 390 PADDLE-SIZE - clamp ] change-computer drop ;
|
||||||
|
|
||||||
|
:: move-computer ( GADGET -- )
|
||||||
|
GADGET ball>> pos>> first :> X
|
||||||
|
GADGET computer>> PADDLE-SIZE 2/ + :> COMPUTER
|
||||||
|
|
||||||
|
! ball on the left
|
||||||
|
X BALL-SIZE + COMPUTER - dup 0 < [
|
||||||
|
>integer -10 max 0 [a,b] random
|
||||||
|
GADGET swap move-computer-by
|
||||||
|
] [ drop ] if
|
||||||
|
|
||||||
|
! ball on the right
|
||||||
|
X COMPUTER - dup 0 > [
|
||||||
|
>integer 10 min [0,b] random
|
||||||
|
GADGET swap move-computer-by
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
|
:: bounce-off-paddle ( BALL PADDLE -- )
|
||||||
|
BALL pos>> first BALL-SIZE 2 / +
|
||||||
|
PADDLE PADDLE-SIZE 2 / + - 1/4 *
|
||||||
|
BALL vel>> second neg BOUNCE * MAX-SPEED min 2array
|
||||||
|
BALL vel<< ;
|
||||||
|
|
||||||
|
:: ?bounce-off-paddle ( BALL GADGET PADDLE -- )
|
||||||
|
BALL pos>> first dup BALL-SIZE +
|
||||||
|
PADDLE dup PADDLE-SIZE + '[ _ _ between? ] either? [
|
||||||
|
BALL PADDLE bounce-off-paddle
|
||||||
|
] [
|
||||||
|
GADGET t >>game-over? timer>> stop-timer
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: bounce-off-wall ( BALL -- )
|
||||||
|
0 swap vel>> [ neg ] change-nth ;
|
||||||
|
|
||||||
|
:: on-tick ( GADGET -- )
|
||||||
|
GADGET move-player
|
||||||
|
GADGET move-ball
|
||||||
|
GADGET move-computer
|
||||||
|
|
||||||
:: iterate-system ( GADGET -- )
|
|
||||||
GADGET field>> :> FIELD
|
|
||||||
GADGET ball>> :> BALL
|
GADGET ball>> :> BALL
|
||||||
GADGET player>> :> PLAYER
|
GADGET player>> :> PLAYER
|
||||||
GADGET computer>> :> COMPUTER
|
GADGET computer>> :> COMPUTER
|
||||||
|
|
||||||
BALL FIELD in-bounds? [
|
BALL pos>> first2 :> ( X Y )
|
||||||
|
BALL vel>> first2 :> ( DX DY )
|
||||||
|
|
||||||
PLAYER FIELD align-paddle-with-mouse
|
{ [ DY 0 > ] [ Y 380 >= ] } 0&&
|
||||||
|
[ BALL GADGET PLAYER ?bounce-off-paddle ] when
|
||||||
|
|
||||||
BALL 1 move-for
|
{ [ DY 0 < ] [ Y 10 <= ] } 0&&
|
||||||
|
[ BALL GADGET COMPUTER ?bounce-off-paddle ] when
|
||||||
|
|
||||||
! computer reaction
|
X { [ 10 <= ] [ 380 >= ] } 1||
|
||||||
|
[ BALL bounce-off-wall ] when
|
||||||
|
|
||||||
BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
|
GADGET relayout-1 ;
|
||||||
BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
|
|
||||||
|
|
||||||
! check if ball bounced off something
|
: com-new-game ( gadget -- )
|
||||||
|
initial-state timer>> start-timer ;
|
||||||
|
|
||||||
! player-blocked-ball?
|
: com-pause ( gadget -- )
|
||||||
BALL PLAYER { [ above? ] [ in-between-horizontally? ] } 2&&
|
dup game-over?>> [
|
||||||
[ BALL PLAYER bounce-off-paddle ] when
|
dup timer>> dup thread>>
|
||||||
|
[ stop-timer ] [ restart-timer ] if
|
||||||
|
] unless relayout-1 ;
|
||||||
|
|
||||||
! computer-blocked-ball?
|
pong-gadget "gestures" f {
|
||||||
BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } 2&&
|
{ T{ key-down { sym "n" } } com-new-game }
|
||||||
[ BALL COMPUTER bounce-off-paddle ] when
|
{ T{ key-down { sym " " } } com-pause }
|
||||||
|
} define-command-map
|
||||||
|
|
||||||
! bounced-off-wall?
|
MAIN-WINDOW: pong-window {
|
||||||
BALL FIELD in-between-horizontally? not
|
{ title "PONG" }
|
||||||
[ BALL reverse-horizontal-velocity ] when
|
{ window-controls
|
||||||
|
{ normal-title-bar close-button minimize-button } }
|
||||||
] [ t GADGET paused<< ] if ;
|
} <pong-gadget> >>gadgets ;
|
||||||
|
|
||||||
:: start-pong-thread ( GADGET -- )
|
|
||||||
f GADGET paused<< [
|
|
||||||
[
|
|
||||||
GADGET paused>>
|
|
||||||
[ f ]
|
|
||||||
[ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
|
|
||||||
if
|
|
||||||
] loop
|
|
||||||
] in-thread ;
|
|
||||||
|
|
||||||
MAIN-WINDOW: pong-window
|
|
||||||
{ { title "PONG" } }
|
|
||||||
pong [ >>gadgets ] [ start-pong-thread ] bi ;
|
|
||||||
|
|
|
||||||
|
|
@ -1 +1,2 @@
|
||||||
|
demos
|
||||||
games
|
games
|
||||||
|
|
|
||||||
|
|
@ -53,7 +53,7 @@
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
// Record compilation time
|
// Record compilation time
|
||||||
#define FACTOR_COMPILE_TIME __TIMESTAMP__
|
#define FACTOR_COMPILE_TIME __DATE__ " " __TIME__
|
||||||
|
|
||||||
// Detect target CPU type
|
// Detect target CPU type
|
||||||
#if defined(__arm__)
|
#if defined(__arm__)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue