processing.shapes: some cleanup.
John Benediktsson
parent
c5ec44cc2c
commit
575aced0f7
|
|
@ -89,33 +89,33 @@ METHOD: distance { sequence sequence } v- norm ;
|
|||
|
||||
! A class for objects with a position
|
||||
|
||||
TUPLE: <pos> pos ;
|
||||
TUPLE: pos pos ;
|
||||
|
||||
METHOD: x { <pos> } pos>> first ;
|
||||
METHOD: y { <pos> } pos>> second ;
|
||||
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: (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: 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: 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: above? { pos number } [ y ] dip > ;
|
||||
METHOD: below? { pos number } [ y ] dip < ;
|
||||
|
||||
METHOD: move-by { <pos> sequence } '[ _ v+ ] change-pos drop ;
|
||||
METHOD: move-by { pos sequence } '[ _ v+ ] change-pos drop ;
|
||||
|
||||
METHOD: distance { <pos> <pos> } [ pos>> ] bi@ distance ;
|
||||
METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! A class for objects with velocity. It inherits from <pos>. Hey, if
|
||||
! 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 ;
|
||||
TUPLE: vel < pos vel ;
|
||||
|
||||
: moving-up? ( obj -- ? ) vel>> y 0 > ;
|
||||
: moving-down? ( obj -- ? ) vel>> y 0 < ;
|
||||
|
|
@ -130,15 +130,15 @@ TUPLE: <vel> < <pos> vel ;
|
|||
! The 'pos' slot indicates the lower left hand corner of the
|
||||
! rectangle. The 'dim' is holds the width and height.
|
||||
|
||||
TUPLE: <rectangle> < <pos> dim ;
|
||||
TUPLE: rectangle < pos dim ;
|
||||
|
||||
METHOD: width { <rectangle> } dim>> first ;
|
||||
METHOD: height { <rectangle> } dim>> second ;
|
||||
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 + ;
|
||||
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>> ;
|
||||
|
||||
|
|
@ -147,40 +147,40 @@ METHOD: top { <rectangle> } [ y ] [ height ] 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: 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: below? { pos rectangle } [ y ] [ bottom ] bi* < ;
|
||||
METHOD: above? { pos rectangle } [ y ] [ top ] bi* > ;
|
||||
|
||||
METHOD: horizontal-interval { <rectangle> }
|
||||
METHOD: horizontal-interval { rectangle }
|
||||
[ left ] [ right ] bi [a,b] ;
|
||||
|
||||
METHOD: in-between-horizontally? { <pos> <rectangle> }
|
||||
METHOD: in-between-horizontally? { pos rectangle }
|
||||
[ x ] [ horizontal-interval ] bi* interval-contains? ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <extent> left right bottom top ;
|
||||
TUPLE: extent left right bottom top ;
|
||||
|
||||
METHOD: left { <extent> } left>> ;
|
||||
METHOD: right { <extent> } right>> ;
|
||||
METHOD: bottom { <extent> } bottom>> ;
|
||||
METHOD: top { <extent> } 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: 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-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: 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* > ;
|
||||
METHOD: below? { sequence rectangle } [ y ] [ bottom ] bi* < ;
|
||||
METHOD: above? { sequence rectangle } [ y ] [ top ] bi* > ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -218,7 +218,7 @@ METHOD: above? { sequence <rectangle> } [ y ] [ top ] bi* > ;
|
|||
|
||||
GENERIC: within? ( a b -- ? )
|
||||
|
||||
METHOD: within? { <pos> <rectangle> }
|
||||
METHOD: within? { pos rectangle }
|
||||
{
|
||||
[ left to-the-right-of? ]
|
||||
[ right to-the-left-of? ]
|
||||
|
|
|
|||
|
|
@ -8,114 +8,88 @@ FROM: multi-methods => GENERIC: METHOD: ;
|
|||
FROM: syntax => M: ;
|
||||
IN: pong
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
|
||||
!
|
||||
! Which was based on this Nodebox version: http://billmill.org/pong.html
|
||||
! by Bill Mill.
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: clamp-to-interval ( x interval -- x )
|
||||
[ from>> first max ] [ to>> first min ] bi ;
|
||||
[ from>> first max ] [ to>> first min ] bi ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
TUPLE: play-field < rectangle ;
|
||||
|
||||
TUPLE: <play-field> < <rectangle> ;
|
||||
TUPLE: <paddle> < <rectangle> ;
|
||||
TUPLE: paddle < rectangle ;
|
||||
|
||||
TUPLE: <computer> < <paddle> { speed initial: 10 } ;
|
||||
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 } ;
|
||||
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&& ;
|
||||
{
|
||||
[ 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!) ;
|
||||
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 -- )
|
||||
|
||||
METHOD: draw { <paddle> } [ bottom-left ] [ dim>> ] bi rectangle ;
|
||||
METHOD: draw { <ball> } [ pos>> ] [ diameter>> 2 / ] bi circle ;
|
||||
METHOD: draw { paddle } [ bottom-left ] [ dim>> ] bi draw-rectangle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
METHOD: draw { ball } [ pos>> ] [ diameter>> 2 / ] bi draw-circle ;
|
||||
|
||||
TUPLE: <pong> < gadget paused field ball player computer ;
|
||||
TUPLE: pong-gadget < gadget paused field ball player computer ;
|
||||
|
||||
: pong ( -- gadget )
|
||||
<pong> new
|
||||
T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
|
||||
T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
|
||||
T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
|
||||
T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
|
||||
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{ paddle { pos { 200 396 } } { dim { 75 4 } } } clone >>player
|
||||
T{ computer { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
|
||||
|
||||
M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
|
||||
M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
|
||||
M: pong-gadget pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
M: pong-gadget ungraft* ( <pong> -- ) t >>paused drop ;
|
||||
|
||||
M:: <pong> draw-gadget* ( PONG -- )
|
||||
|
||||
PONG computer>> draw
|
||||
PONG player>> draw
|
||||
PONG ball>> draw ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
M:: pong-gadget draw-gadget* ( PONG -- )
|
||||
PONG computer>> draw
|
||||
PONG player>> draw
|
||||
PONG ball>> draw ;
|
||||
|
||||
:: iterate-system ( GADGET -- )
|
||||
|
||||
GADGET field>> :> FIELD
|
||||
GADGET ball>> :> BALL
|
||||
GADGET player>> :> PLAYER
|
||||
|
|
@ -148,22 +122,15 @@ M:: <pong> draw-gadget* ( PONG -- )
|
|||
|
||||
] [ t GADGET paused<< ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: start-pong-thread ( GADGET -- )
|
||||
f GADGET paused<<
|
||||
[
|
||||
[
|
||||
GADGET paused>>
|
||||
[ f ]
|
||||
[ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
|
||||
if
|
||||
]
|
||||
loop
|
||||
]
|
||||
in-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
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" } }
|
||||
|
|
|
|||
|
|
@ -3,78 +3,56 @@ kernel locals math math.vectors namespaces opengl opengl.gl
|
|||
opengl.glu sequences sequences.generalizations shuffle ;
|
||||
IN: processing.shapes
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: do-state ( mode quot -- ) swap glBegin call glEnd ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: fill-color
|
||||
SYMBOL: stroke-color
|
||||
|
||||
COLOR: black stroke-color set-global
|
||||
COLOR: white fill-color set-global
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: fill-mode ( -- )
|
||||
GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||
fill-color get gl-color ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||
fill-color get gl-color ;
|
||||
|
||||
: stroke-mode ( -- )
|
||||
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||
stroke-color get gl-color ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||
stroke-color get gl-color ;
|
||||
|
||||
: gl-vertex-2d ( vertex -- ) first2 glVertex2d ;
|
||||
|
||||
: gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: draw-point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ;
|
||||
: draw-point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ;
|
||||
: draw-points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
|
||||
|
||||
: point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ;
|
||||
: point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ;
|
||||
: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
|
||||
: draw-line** ( x y x y -- )
|
||||
stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: draw-line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
|
||||
|
||||
: line** ( x y x y -- )
|
||||
stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
|
||||
: draw-lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
|
||||
|
||||
: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
|
||||
|
||||
: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
|
||||
|
||||
: line ( seq -- ) lines ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: draw-line ( seq -- ) draw-lines ;
|
||||
|
||||
: line-strip ( seq -- ) stroke-mode GL_LINE_STRIP [ gl-vertices-2d ] do-state ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: draw-triangles ( seq -- )
|
||||
[ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ]
|
||||
[ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
|
||||
|
||||
: triangles ( seq -- )
|
||||
[ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ]
|
||||
[ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
|
||||
: draw-triangle ( seq -- ) draw-triangles ;
|
||||
|
||||
: triangle ( seq -- ) triangles ;
|
||||
: draw-triangle* ( a b c -- ) 3array draw-triangles ;
|
||||
|
||||
: triangle* ( a b c -- ) 3array triangles ;
|
||||
: draw-triangle** ( x y x y x y -- ) 6 narray 2 group draw-triangles ;
|
||||
|
||||
: triangle** ( x y x y x y -- ) 6 narray 2 group triangles ;
|
||||
: draw-polygon ( seq -- )
|
||||
[ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ]
|
||||
[ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: polygon ( seq -- )
|
||||
[ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ]
|
||||
[ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: rectangle ( loc dim -- )
|
||||
:: draw-rectangle ( loc dim -- )
|
||||
loc first2 :> ( x y )
|
||||
dim first2 :> ( dx dy )
|
||||
|
||||
|
|
@ -83,38 +61,28 @@ COLOR: white fill-color set-global
|
|||
x dx + y dy + 2array
|
||||
x y dy + 2array
|
||||
4array
|
||||
polygon ;
|
||||
draw-polygon ;
|
||||
|
||||
: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: draw-rectangle* ( x y width height -- ) [ 2array ] 2bi@ draw-rectangle ;
|
||||
|
||||
: gl-translate-2d ( pos -- ) first2 0 glTranslated ;
|
||||
|
||||
: gl-scale-2d ( xy -- ) first2 1 glScaled ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: gl-ellipse ( center dim -- )
|
||||
glPushMatrix
|
||||
glPushMatrix
|
||||
[ gl-translate-2d ] [ gl-scale-2d ] bi*
|
||||
gluNewQuadric
|
||||
dup 0 0.5 20 1 gluDisk
|
||||
dup 0 0.5 20 1 gluDisk
|
||||
gluDeleteQuadric
|
||||
glPopMatrix ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
glPopMatrix ;
|
||||
|
||||
: gl-get-line-width ( -- width )
|
||||
GL_LINE_WIDTH 0 double <ref> tuck glGetDoublev double deref ;
|
||||
GL_LINE_WIDTH 0 double <ref> tuck glGetDoublev double deref ;
|
||||
|
||||
: ellipse ( center dim -- )
|
||||
GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||
[ stroke-color get gl-color gl-ellipse ]
|
||||
[ fill-color get gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
|
||||
: draw-ellipse ( center dim -- )
|
||||
GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||
[ stroke-color get gl-color gl-ellipse ]
|
||||
[ fill-color get gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: circle ( center size -- ) dup 2array ellipse ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: draw-circle ( center size -- ) dup 2array draw-ellipse ;
|
||||
|
|
|
|||
|
|
@ -1,100 +1,60 @@
|
|||
USING: accessors calendar circular colors colors.constants
|
||||
kernel locals math math.order math.vectors namespaces opengl
|
||||
processing.shapes sequences threads ui ui.gadgets ui.gestures
|
||||
ui.render ;
|
||||
USING: accessors arrays calendar circular colors
|
||||
colors.constants fry kernel locals math math.order math.vectors
|
||||
namespaces opengl processing.shapes sequences threads ui
|
||||
ui.gadgets ui.gestures ui.render ;
|
||||
|
||||
IN: trails
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Example 33-15 from the Processing book
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: mouse ( -- point )
|
||||
! Return the mouse location relative to the current gadget
|
||||
hand-loc get hand-gadget get screen-loc v- ;
|
||||
|
||||
! Return the mouse location relative to the current gadget
|
||||
|
||||
: mouse ( -- point ) hand-loc get hand-gadget get screen-loc v- ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: point-list ( n -- seq ) [ { 0 0 } ] replicate <circular> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: point-list ( n -- seq ) { 0 0 } <array> <circular> ;
|
||||
|
||||
: percent->radius ( percent -- radius ) neg 1 + 25 * 5 max ;
|
||||
|
||||
: dot ( pos percent -- ) percent->radius circle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: dot ( pos percent -- ) percent->radius draw-circle ;
|
||||
|
||||
TUPLE: trails-gadget < gadget paused points ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-system ( GADGET -- )
|
||||
|
||||
! Add a valid point if the mouse is in the gadget
|
||||
! Otherwise, add an "invisible" point
|
||||
|
||||
hand-gadget get GADGET =
|
||||
[ mouse GADGET points>> circular-push ]
|
||||
[ { -10 -10 } GADGET points>> circular-push ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Add a valid point if the mouse is in the gadget
|
||||
! Otherwise, add an "invisible" point
|
||||
hand-gadget get GADGET = [ mouse ] [ { -10 -10 } ] if
|
||||
GADGET points>> circular-push ;
|
||||
|
||||
:: start-trails-thread ( GADGET -- )
|
||||
GADGET f >>paused drop
|
||||
[
|
||||
GADGET f >>paused drop
|
||||
[
|
||||
GADGET paused>>
|
||||
[ f ]
|
||||
[ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
|
||||
if
|
||||
]
|
||||
loop
|
||||
]
|
||||
"trails" spawn drop ;
|
||||
[
|
||||
GADGET paused>>
|
||||
[ f ]
|
||||
[ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
|
||||
if
|
||||
]
|
||||
loop
|
||||
] "trails" spawn drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
M: trails-gadget ungraft* t >>paused drop ;
|
||||
|
||||
M: trails-gadget ungraft* ( trails-gadget -- ) t >>paused drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M: trails-gadget pref-dim* ( trails-gadget -- dim ) drop { 500 500 } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
M: trails-gadget pref-dim* drop { 500 500 } ;
|
||||
|
||||
: each-percent ( seq quot -- )
|
||||
[
|
||||
dup length
|
||||
[ iota ] [ [ / ] curry ] bi
|
||||
[ 1 + ] prepose
|
||||
] dip compose
|
||||
2each ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
[ dup length ] dip '[ 1 + _ / @ ] each-index ; inline
|
||||
|
||||
M:: trails-gadget draw-gadget* ( GADGET -- )
|
||||
T{ rgba f 1 1 1 0.4 } \ fill-color set ! White, with some transparency
|
||||
T{ rgba f 0 0 0 0 } \ stroke-color set ! no stroke
|
||||
|
||||
COLOR: black gl-clear
|
||||
|
||||
GADGET points>> [ dot ] each-percent ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: <trails-gadget> ( -- trails-gadget )
|
||||
|
||||
trails-gadget new
|
||||
|
||||
300 point-list >>points
|
||||
|
||||
t >>clipped?
|
||||
|
||||
dup start-trails-thread ;
|
||||
trails-gadget new
|
||||
300 point-list >>points
|
||||
t >>clipped?
|
||||
dup start-trails-thread ;
|
||||
|
||||
MAIN-WINDOW: trails-window
|
||||
{ { title "Trails" } }
|
||||
|
|
|
|||
Loading…
Reference in New Issue