[ lookup-privilege ] dip\r
[\r
TOKEN_PRIVILEGES-Privileges\r
- [ 0 ] dip LUID_AND_ATTRIBUTES-nth\r
set-LUID_AND_ATTRIBUTES-Luid\r
] keep ;\r
\r
-USING: alien alien.c-types windows.com.syntax init
-windows.com.syntax.private windows.com continuations kernel
+USING: alien alien.c-types alien.accessors windows.com.syntax
+init windows.com.syntax.private windows.com continuations kernel
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
-destructors fry math.parser generalizations sets ;
+destructors fry math.parser generalizations sets
+specialized-arrays.alien specialized-arrays.direct.alien ;
IN: windows.com.wrapper
TUPLE: com-wrapper callbacks vtbls disposed ;
_ case
[
"void*" heap-size * rot <displaced-alien> com-add-ref
- 0 rot set-void*-nth S_OK
- ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
+ swap 0 set-alien-cell S_OK
+ ] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if*
] ;
: (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * '[
- _ swap <displaced-alien>
- 0 over ulong-nth
- 1+ [ 0 rot set-ulong-nth ] keep
+ _
+ [ alien-unsigned-4 1+ dup ]
+ [ set-alien-unsigned-4 ]
+ 2bi
] ;
: (make-release) ( interfaces -- quot )
length "void*" heap-size * '[
- _ over <displaced-alien>
- 0 over ulong-nth
- 1- [ 0 rot set-ulong-nth ] keep
- dup zero? [ swap (free-wrapped-object) ] [ nip ] if
+ _
+ [ drop ]
+ [ alien-unsigned-4 1- dup ]
+ [ set-alien-unsigned-4 ]
+ 2tri
+ dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
] ;
: (make-iunknown-methods) ( interfaces -- quots )
: (malloc-wrapped-object) ( wrapper -- wrapped-object )
vtbls>> length "void*" heap-size *
[ "ulong" heap-size + malloc ] keep
- over <displaced-alien>
- 1 0 rot set-ulong-nth ;
+ [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
: (callbacks>vtbl) ( callbacks -- vtbl )
[ execute ] void*-array{ } map-as underlying>> malloc-byte-array ;
: com-wrap ( object wrapper -- wrapped-object )
[ vtbls>> ] [ (malloc-wrapped-object) ] bi
- [ [ set-void*-nth ] curry each-index ] keep
+ [ over length <direct-void*-array> 0 swap copy ] keep
[ +wrapped-objects+ get-global set-at ] keep ;
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel alien.c-types combinators namespaces make arrays
+ sequences sequences.lib namespaces.lib splitting
+ math math.functions math.vectors math.trig
+ opengl.gl opengl.glu opengl ui ui.gadgets.slate
+ vars colors self self.slots
+ random-weighted colors.hsv cfdg.gl accessors
+ ui.gadgets.handler ui.gestures assocs ui.gadgets macros
+ qualified specialized-arrays.double ;
+
+QUALIFIED: syntax
+
+IN: cfdg
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SELF-SLOTS: hsva
+
+: clear-color ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! if (adjustment < 0)
+! base + base * adjustment
+
+! if (adjustment > 0)
+! base + (1 - base) * adjustment
+
+: adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hue ( num -- ) hue-> + 360 mod ->hue ;
+
+: saturation ( num -- ) saturation-> swap adjust ->saturation ;
+: brightness ( num -- ) value-> swap adjust ->value ;
+: alpha ( num -- ) alpha-> swap adjust ->alpha ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: h ( num -- ) hue ;
+: sat ( num -- ) saturation ;
+: b ( num -- ) brightness ;
+: a ( num -- ) alpha ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: color-stack
+
+: init-color-stack ( -- ) V{ } clone >color-stack ;
+
+: push-color ( -- ) self> color-stack> push self> clone >self ;
+
+: pop-color ( -- ) color-stack> pop dup >self gl-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
+
+: double-nth* ( c-array indices -- seq )
+ swap byte-array>double-array [ nth ] curry map ;
+
+: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ;
+
+VAR: threshold
+
+: iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! cos 2a sin 2a 0 0
+! sin 2a -cos 2a 0 0
+! 0 0 1 0
+! 0 0 0 1
+
+! column major order
+
+: gl-flip ( angle -- ) deg>rad dup dup dup
+ [ 2 * cos , 2 * sin , 0 , 0 ,
+ 2 * sin , 2 * cos neg , 0 , 0 ,
+ 0 , 0 , 1 , 0 ,
+ 0 , 0 , 0 , 1 , ]
+ double-array{ } make underlying>> glMultMatrixd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: circle ( -- )
+ self> gl-color
+ gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
+
+: triangle ( -- )
+ self> gl-color
+ GL_POLYGON glBegin
+ 0 0.577 glVertex2d
+ 0.5 -0.289 glVertex2d
+ -0.5 -0.289 glVertex2d
+ glEnd ;
+
+: square ( -- )
+ self> gl-color
+ GL_POLYGON glBegin
+ -0.5 0.5 glVertex2d
+ 0.5 0.5 glVertex2d
+ 0.5 -0.5 glVertex2d
+ -0.5 -0.5 glVertex2d
+ glEnd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: size ( scale -- ) dup 1 glScaled ;
+
+: size* ( scale-x scale-y -- ) 1 glScaled ;
+
+: rotate ( angle -- ) 0 0 1 glRotated ;
+
+: x ( x -- ) 0 0 glTranslated ;
+
+: y ( y -- ) 0 swap 0 glTranslated ;
+
+: flip ( angle -- ) gl-flip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: s ( scale -- ) size ;
+: s* ( scale-x scale-y -- ) size* ;
+: r ( angle -- ) rotate ;
+: f ( angle -- ) flip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: do ( quot -- )
+ push-modelview-matrix
+ push-color
+ call
+ pop-modelview-matrix
+ pop-color ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: recursive ( quot -- ) iterate? swap when ; inline
+
+: multi ( seq -- ) random-weighted* call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [rules] ( seq -- quot )
+ [ unclip swap [ [ do ] curry ] map concat 2array ] map
+ [ call-random-weighted ] swap prefix
+ [ when ] swap prefix
+ [ iterate? ] swap append ;
+
+MACRO: rules ( seq -- quot ) [rules] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [rule] ( seq -- quot )
+ [ [ do ] swap prefix ] map concat
+ [ when ] swap prefix
+ [ iterate? ] prepend ;
+
+MACRO: rule ( seq -- quot ) [rule] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: background
+
+: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
+
+: set-background ( -- )
+ set-initial-background
+ background> call
+ self> clear-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: rewrite-closures ;
+
+VAR: viewport ! { left width bottom height }
+
+VAR: start-shape
+
+: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: dlist
+
+! : build-model-dlist ( -- )
+! 1 glGenLists dlist set
+! dlist get GL_COMPILE_AND_EXECUTE glNewList
+! start-shape> call
+! glEndList ;
+
+: build-model-dlist ( -- )
+ 1 glGenLists dlist set
+ dlist get GL_COMPILE_AND_EXECUTE glNewList
+
+ set-initial-color
+
+ self> gl-color
+
+ start-shape> call
+
+ glEndList ;
+
+: display ( -- )
+
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ viewport> first dup viewport> second +
+ viewport> third dup viewport> fourth + gluOrtho2D
+
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+
+ set-background
+
+ GL_COLOR_BUFFER_BIT glClear
+
+ init-modelview-matrix-stack
+ init-color-stack
+
+ dlist get not
+ [ build-model-dlist ]
+ [ dlist get glCallList ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
+
+: cfdg-window* ( -- slate )
+ C[ display ] <slate>
+ { 500 500 } >>pdim
+ C[ delete-dlist ] >>ungraft
+ dup "CFDG" open-window ;
+
+: cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: the-slate
+
+: rebuild ( -- ) delete-dlist the-slate get relayout-1 ;
+
+: <cfdg-gadget> ( -- slate )
+ C[ display ] <slate>
+ dup the-slate set
+ { 500 500 } >>pdim
+ C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
+ <handler>
+ H{ } clone
+ T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
+ T{ button-down } C[ drop rebuild ] swap pick set-at
+ >>table ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: fry
+
+: cfdg-window. ( quot -- )
+ '[ [ @ <cfdg-gadget> "CFDG" open-window ] with-scope ] with-ui ;
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel alien.c-types namespaces sequences opengl.gl ;
+
+IN: cfdg.gl
+
+: get-modelview-matrix ( -- alien )
+ GL_MODELVIEW_MATRIX 16 "GLdouble" <c-array> tuck glGetDoublev ;
+
+SYMBOL: modelview-matrix-stack
+
+: init-modelview-matrix-stack ( -- ) V{ } clone modelview-matrix-stack set ;
+
+: push-modelview-matrix ( -- )
+ get-modelview-matrix modelview-matrix-stack get push ;
+
+: pop-modelview-matrix ( -- ) modelview-matrix-stack get pop glLoadMatrixd ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces math random opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.aqua-star
+
+: tentacle ( -- )
+iterate? [
+ { { 1 [ circle
+ [ .23 y .99 s .002 b tentacle ] do ] }
+ { 1 [ circle
+ [ .17 y 2 r .99 s .002 b tentacle ] do ] }
+ { 1 [ circle
+ [ .12 y -2 r .99 s .001 b tentacle ] do ] } }
+ call-random-weighted
+] when ;
+
+: anemone ( -- )
+iterate? [
+ tentacle
+ [ 10 x -11 r .995 s -.002 b anemone ] do
+] when ;
+
+: anemone-begin ( -- ) [ 196 hue 0.8324 sat 1 b anemone ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -1 b ] >background
+ { -60 140 -120 140 } >viewport
+ 0.1 >threshold
+ [ anemone-begin ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces sequences math
+ opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.chiaroscuro
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: white
+
+: black ( -- )
+ {
+ { 60 [ 0.6 s circle ] [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] }
+ { 1 [ white black ] }
+ }
+ rules ;
+
+: white ( -- )
+ {
+ { 60 [ 0.6 s circle ] [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] }
+ { 1 [ black white ] }
+ }
+ rules ;
+
+: chiaroscuro ( -- ) { [ 0.5 b black ] } rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -0.5 b ] >background
+ { -3 6 -2 6 } >viewport
+ 0.03 >threshold
+ [ chiaroscuro ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 2 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { "bundle-name" "cfdg.models.flower6.app" }
+}
--- /dev/null
+
+USING: kernel namespaces sequences math
+ opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.flower6
+
+: petal6 ( -- )
+iterate? [
+ [ 1 0.001 s* square ] do
+ [ -0.5 x 0.01 s -1 b circle ] do
+ [ 0.5 x 120.21 r 0.996 s 0.5 x 0.005 b petal6 ] do
+] when ;
+
+: flower6 ( -- )
+12 [ [ [ 30 r ] times petal6 ] do ] each
+12 [ [ [ 30 r ] times 90 flip petal6 ] do ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -1 2 -1 2 } >viewport
+ 0.01 >threshold
+ [ flower6 ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
+
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.game1-turn6
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: f-triangles ( -- )
+ {
+ [ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.80 b triangle ]
+ [ 10 hue 0.9 sat 0.33 b triangle ]
+ [ 0.9 s 10 hue 0.5 sat 1.00 b triangle ]
+ [ 0.8 s 5 r f-triangles ]
+ }
+ rule ;
+
+: f-squares ( -- )
+ {
+ [ 0.1 x 0.1 y -0.33 alpha 250 hue 0.70 sat 0.80 b square ]
+ [ 220 hue 0.90 sat 0.33 b square ]
+ [ 0.9 s 220 hue 0.25 sat 1.00 b square ]
+ [ 0.8 s 5 r f-squares ]
+ }
+ rule ;
+
+DEFER: start
+
+: spiral ( -- )
+ {
+ { 1 [ f-squares ]
+ [ 0.5 x 0.5 y 45 r f-triangles ]
+ [ 1 y 25 r 0.9 s spiral ] }
+
+ { 0.022 [ 90 flip 50 hue start ] }
+ }
+ rules ;
+
+: start ( -- )
+ [ spiral ] do
+ [ 120 r spiral ] do
+ [ 240 r spiral ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ 66 hue 0.4 sat 0.5 b ] >background
+ { -5 10 -5 10 } >viewport
+ 0.001 >threshold
+ [ start ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.lesson
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shapes ( -- )
+[ square ] do
+[ 0.3 b circle ] do
+[ 0.5 b triangle ] do
+[ 0.7 b 60 r triangle ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-1 ( -- )
+[ 2 x 5 y 3 size square ] do
+[ 6 x 5 y 3 size circle ] do
+[ 4 x 2 y 3 size triangle ] do
+[ 1 y 3 size shapes ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: foursquare ( -- )
+[ 0 x 0 y 5 3 size* square ] do
+[ 0 x 5 y 2 4 size* square ] do
+[ 5 x 5 y 3 size square ] do
+[ 5 x 0 y 2 size square ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-2 ( -- )
+[ square ] do
+[ 3 x 7 y square ] do
+[ 5 x 7 y 30 r square ] do
+[ 3 x 5 y 0.75 size square ] do
+[ 5 x 5 y 0.5 b square ] do
+[ 7 x 6 y 45 r 0.7 size 0.7 b square ] do
+[ 5 x 1 y 10 r 0.2 size foursquare ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: spiral ( -- )
+iterate? [
+ [ 0.5 size circle ] do
+ [ 0.2 y -3 r 0.995 size spiral ] do
+] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-3 ( -- ) [ 0 x 3 y spiral ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: tree
+
+: branch-left ( -- )
+{ { 1 [ 20 r tree ] }
+ { 1 [ 30 r tree ] }
+ { 1 [ 40 r tree ] }
+ { 1 [ ] } } random-weighted* do ;
+
+: branch-right ( -- )
+{ { 1 [ -20 r tree ] }
+ { 1 [ -30 r tree ] }
+ { 1 [ -40 r tree ] }
+ { 1 [ ] } } random-weighted* do ;
+
+: branch ( -- ) branch-left branch-right ;
+
+: tree ( -- )
+iterate? [
+ {
+ { 20 [ [ 0.25 size circle ] do
+ [ 0.1 y 0.97 size tree ] do ] }
+ { 1.5 [ branch ] }
+ } random-weighted* do
+] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-4 ( -- )
+[ 1 x 0 y tree ] do
+[ 6 x 0 y tree ] do
+[ 1 x 4 y tree ] do
+[ 6 x 4 y tree ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: toc ( -- )
+[ 0 x 0 y chapter-1 ] do
+[ 10 x 0 y chapter-2 ] do
+[ 0 x -10 y chapter-3 ] do
+[ 10 x -10 y chapter-4 ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -5 25 -15 25 } >viewport
+ 0.03 >threshold
+ [ toc ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
+
--- /dev/null
+
+USING: namespaces sequences math random-weighted cfdg ;
+
+IN: cfdg.models.rules08
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: insct ( -- )
+ [ 1.5 5.5 size* -1 brightness triangle ] do
+ 10
+ [ [ [ 1 0.9 size* -0.15 y 0.05 brightness ] times 1 5 size* triangle ] do ]
+ each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: line
+
+: ligne ( -- )
+ {
+ { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] }
+ { 0.5 [ ] }
+ }
+ rules ;
+
+: line ( -- ) { [ insct ligne ] } rule ;
+
+: sole ( -- )
+ {
+ { 1 [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] }
+ { 0.01 [ ] }
+ }
+ rules ;
+
+: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -1 b ] >background
+ { -20 40 -20 40 } viewport set
+ [ centre ] >start-shape
+ 0.0001 >threshold ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.sierpinski
+
+: shape ( -- ) circle ;
+
+! : sierpinski ( -- )
+! iterate? [
+! shape
+! [ 0.6 s 5 r 0.2 b -1.5 y 0 x sierpinski ] do
+! [ 0.6 s 5 r -0.2 b 0.75 y -1.2990375 x sierpinski ] do
+! [ 0.6 s 5 r 0.75 y 1.2990375 x sierpinski ] do
+! ] when ;
+
+: sierpinski ( -- )
+iterate? [
+ shape
+ [ -1.5 y 0 x 0.6 s 5 r 0.2 b sierpinski ] do
+ [ 0.75 y -1.2990375 x 0.6 s 5 r -0.2 b sierpinski ] do
+ [ 0.75 y 1.2990375 x 0.6 s 5 r sierpinski ] do
+] when ;
+
+: top ( -- ) [ -13.5 r 0.5 b sierpinski ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -4 8 -4 8 } >viewport
+ 0.01 >threshold
+ [ top ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.snowflake
+
+: spike ( -- )
+iterate? [
+ { { 1 [ square
+ [ 0.95 y 0.97 s spike ] do ] }
+ { 0.03 [ square
+ [ 60 r spike ] do
+ [ -60 r spike ] do
+ [ 0.95 y 0.97 s spike ] do ] } }
+ call-random-weighted
+] when ;
+
+: snowflake ( -- )
+spike
+[ 60 r spike ] do
+[ 120 r spike ] do
+[ 180 r spike ] do
+[ 240 r spike ] do
+[ 300 r spike ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -40 80 -40 80 } >viewport
+ 0.1 >threshold
+ [ snowflake ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
+
--- /dev/null
+
+USING: namespaces sequences math random-weighted cfdg ;
+
+IN: cfdg.models.spirales
+
+DEFER: line
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: block ( -- ) { [ circle ] [ 0.3 s 60 flip line ] } rule ;
+
+: a1 ( -- ) { [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] [ block ] } rule ;
+
+: line ( -- ) -0.3 a { [ 0 r a1 ] [ 120 r a1 ] [ 240 r a1 ] } rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -1 b ] >background
+ { -20 40 -20 40 } >viewport
+ [ line ] >start-shape
+ 0.04 >threshold ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Implementation of: http://contextfreeart.org
--- /dev/null
+
+USING: kernel accessors locals math math.intervals math.order
+ namespaces sequences threads
+ ui
+ ui.gadgets
+ ui.gestures
+ ui.render
+ calendar
+ multi-methods
+ multi-method-syntax
+ combinators.short-circuit.smart
+ combinators.cleave.enhanced
+ processing.shapes
+ flatland ;
+
+IN: pong
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clamp-to-interval ( x interval -- x )
+ [ from>> first max ] [ to>> first min ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <play-field> < <rectangle> ;
+TUPLE: <paddle> < <rectangle> ;
+
+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? ]
+ } && ;
+
+:: 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 -- )
+
+METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
+METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
+ ! by multi-methods
+
+TUPLE: <pong> < gadget draw closed ;
+
+M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
+M: <pong> draw-gadget* ( <pong> -- ) draw>> call ;
+M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-draw-closure ( -- closure )
+
+ ! Establish some bindings
+
+ [let | PLAY-FIELD [ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } ]
+ BALL [ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } ]
+
+ PLAYER [ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } ]
+ COMPUTER [ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } ] |
+
+ ! Define some internal words in terms of those bindings ...
+
+ [wlet | align-player-with-mouse [ ( -- )
+ PLAYER PLAY-FIELD align-paddle-with-mouse ]
+
+ move-ball [ ( -- ) BALL 1 move-for ]
+
+ player-blocked-ball? [ ( -- ? )
+ BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
+
+ computer-blocked-ball? [ ( -- ? )
+ BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
+
+ bounce-off-wall? [ ( -- ? )
+ BALL PLAY-FIELD in-between-horizontally? not ] |
+
+ ! Note, we're returning a quotation.
+ ! The quotation closes over the bindings established by the 'let'.
+ ! Thus the name of the word 'make-draw-closure'.
+ ! This closure is intended to be placed in the 'draw' slot of a
+ ! <pong> gadget.
+
+ [
+
+ BALL PLAY-FIELD in-bounds?
+ [
+ align-player-with-mouse
+
+ move-ball
+
+ ! computer reaction
+
+ BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
+ BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+
+ ! check if ball bounced off something
+
+ player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
+ computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
+ bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
+
+ ! draw the objects
+
+ COMPUTER draw
+ PLAYER draw
+ BALL draw
+
+ ]
+ when
+
+ ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
+ ! The stack effects in the wlet expression throw
+ ! off the effect for the whole word, so we reset
+ ! it to the correct one here.
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: pong-loop-step ( PONG -- ? )
+ PONG closed>>
+ [ f ]
+ [ PONG relayout-1 25 milliseconds sleep t ]
+ if ;
+
+:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: play-pong ( -- )
+
+ <pong> new-gadget
+ make-draw-closure >>draw
+ dup "PONG" open-window
+
+ start-pong-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: play-pong-main ( -- ) [ play-pong ] with-ui ;
+
+MAIN: play-pong-main
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel alien.c-types combinators namespaces make arrays
- sequences sequences.lib namespaces.lib splitting
- math math.functions math.vectors math.trig
- opengl.gl opengl.glu opengl ui ui.gadgets.slate
- vars colors self self.slots
- random-weighted colors.hsv cfdg.gl accessors
- ui.gadgets.handler ui.gestures assocs ui.gadgets macros
- qualified speicalized-arrays.double ;
-QUALIFIED: syntax
-IN: cfdg
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SELF-SLOTS: hsva
-
-: clear-color ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! if (adjustment < 0)
-! base + base * adjustment
-
-! if (adjustment > 0)
-! base + (1 - base) * adjustment
-
-: adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hue ( num -- ) hue-> + 360 mod ->hue ;
-
-: saturation ( num -- ) saturation-> swap adjust ->saturation ;
-: brightness ( num -- ) value-> swap adjust ->value ;
-: alpha ( num -- ) alpha-> swap adjust ->alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: h ( num -- ) hue ;
-: sat ( num -- ) saturation ;
-: b ( num -- ) brightness ;
-: a ( num -- ) alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: color-stack
-
-: init-color-stack ( -- ) V{ } clone >color-stack ;
-
-: push-color ( -- ) self> color-stack> push self> clone >self ;
-
-: pop-color ( -- ) color-stack> pop dup >self gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
-
-: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ;
-
-VAR: threshold
-
-: iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! cos 2a sin 2a 0 0
-! sin 2a -cos 2a 0 0
-! 0 0 1 0
-! 0 0 0 1
-
-! column major order
-
-: gl-flip ( angle -- ) deg>rad dup dup dup
- [ 2 * cos , 2 * sin , 0 , 0 ,
- 2 * sin , 2 * cos neg , 0 , 0 ,
- 0 , 0 , 1 , 0 ,
- 0 , 0 , 0 , 1 , ]
- double-array{ } make underlying>> glMultMatrixd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: circle ( -- )
- self> gl-color
- gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
-
-: triangle ( -- )
- self> gl-color
- GL_POLYGON glBegin
- 0 0.577 glVertex2d
- 0.5 -0.289 glVertex2d
- -0.5 -0.289 glVertex2d
- glEnd ;
-
-: square ( -- )
- self> gl-color
- GL_POLYGON glBegin
- -0.5 0.5 glVertex2d
- 0.5 0.5 glVertex2d
- 0.5 -0.5 glVertex2d
- -0.5 -0.5 glVertex2d
- glEnd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: size ( scale -- ) dup 1 glScaled ;
-
-: size* ( scale-x scale-y -- ) 1 glScaled ;
-
-: rotate ( angle -- ) 0 0 1 glRotated ;
-
-: x ( x -- ) 0 0 glTranslated ;
-
-: y ( y -- ) 0 swap 0 glTranslated ;
-
-: flip ( angle -- ) gl-flip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: s ( scale -- ) size ;
-: s* ( scale-x scale-y -- ) size* ;
-: r ( angle -- ) rotate ;
-: f ( angle -- ) flip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: do ( quot -- )
- push-modelview-matrix
- push-color
- call
- pop-modelview-matrix
- pop-color ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: recursive ( quot -- ) iterate? swap when ; inline
-
-: multi ( seq -- ) random-weighted* call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [rules] ( seq -- quot )
- [ unclip swap [ [ do ] curry ] map concat 2array ] map
- [ call-random-weighted ] swap prefix
- [ when ] swap prefix
- [ iterate? ] swap append ;
-
-MACRO: rules ( seq -- quot ) [rules] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [rule] ( seq -- quot )
- [ [ do ] swap prefix ] map concat
- [ when ] swap prefix
- [ iterate? ] prepend ;
-
-MACRO: rule ( seq -- quot ) [rule] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: background
-
-: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
-
-: set-background ( -- )
- set-initial-background
- background> call
- self> clear-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: rewrite-closures ;
-
-VAR: viewport ! { left width bottom height }
-
-VAR: start-shape
-
-: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: dlist
-
-! : build-model-dlist ( -- )
-! 1 glGenLists dlist set
-! dlist get GL_COMPILE_AND_EXECUTE glNewList
-! start-shape> call
-! glEndList ;
-
-: build-model-dlist ( -- )
- 1 glGenLists dlist set
- dlist get GL_COMPILE_AND_EXECUTE glNewList
-
- set-initial-color
-
- self> gl-color
-
- start-shape> call
-
- glEndList ;
-
-: display ( -- )
-
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- viewport> first dup viewport> second +
- viewport> third dup viewport> fourth + gluOrtho2D
-
- GL_MODELVIEW glMatrixMode
- glLoadIdentity
-
- set-background
-
- GL_COLOR_BUFFER_BIT glClear
-
- init-modelview-matrix-stack
- init-color-stack
-
- dlist get not
- [ build-model-dlist ]
- [ dlist get glCallList ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
-
-: cfdg-window* ( -- slate )
- C[ display ] <slate>
- { 500 500 } >>pdim
- C[ delete-dlist ] >>ungraft
- dup "CFDG" open-window ;
-
-: cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: the-slate
-
-: rebuild ( -- ) delete-dlist the-slate get relayout-1 ;
-
-: <cfdg-gadget> ( -- slate )
- C[ display ] <slate>
- dup the-slate set
- { 500 500 } >>pdim
- C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
- <handler>
- H{ } clone
- T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
- T{ button-down } C[ drop rebuild ] swap pick set-at
- >>table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: fry
-
-: cfdg-window. ( quot -- )
- '[ [ @ <cfdg-gadget> "CFDG" open-window ] with-scope ] with-ui ;
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel alien.c-types namespaces sequences opengl.gl ;
-
-IN: cfdg.gl
-
-: get-modelview-matrix ( -- alien )
- GL_MODELVIEW_MATRIX 16 "GLdouble" <c-array> tuck glGetDoublev ;
-
-SYMBOL: modelview-matrix-stack
-
-: init-modelview-matrix-stack ( -- ) V{ } clone modelview-matrix-stack set ;
-
-: push-modelview-matrix ( -- )
- get-modelview-matrix modelview-matrix-stack get push ;
-
-: pop-modelview-matrix ( -- ) modelview-matrix-stack get pop glLoadMatrixd ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel namespaces math random opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.aqua-star
-
-: tentacle ( -- )
-iterate? [
- { { 1 [ circle
- [ .23 y .99 s .002 b tentacle ] do ] }
- { 1 [ circle
- [ .17 y 2 r .99 s .002 b tentacle ] do ] }
- { 1 [ circle
- [ .12 y -2 r .99 s .001 b tentacle ] do ] } }
- call-random-weighted
-] when ;
-
-: anemone ( -- )
-iterate? [
- tentacle
- [ 10 x -11 r .995 s -.002 b anemone ] do
-] when ;
-
-: anemone-begin ( -- ) [ 196 hue 0.8324 sat 1 b anemone ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -1 b ] >background
- { -60 140 -120 140 } >viewport
- 0.1 >threshold
- [ anemone-begin ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces sequences math
- opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.chiaroscuro
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: white
-
-: black ( -- )
- {
- { 60 [ 0.6 s circle ] [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] }
- { 1 [ white black ] }
- }
- rules ;
-
-: white ( -- )
- {
- { 60 [ 0.6 s circle ] [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] }
- { 1 [ black white ] }
- }
- rules ;
-
-: chiaroscuro ( -- ) { [ 0.5 b black ] } rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -0.5 b ] >background
- { -3 6 -2 6 } >viewport
- 0.03 >threshold
- [ chiaroscuro ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 2 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { "bundle-name" "cfdg.models.flower6.app" }
-}
+++ /dev/null
-
-USING: kernel namespaces sequences math
- opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.flower6
-
-: petal6 ( -- )
-iterate? [
- [ 1 0.001 s* square ] do
- [ -0.5 x 0.01 s -1 b circle ] do
- [ 0.5 x 120.21 r 0.996 s 0.5 x 0.005 b petal6 ] do
-] when ;
-
-: flower6 ( -- )
-12 [ [ [ 30 r ] times petal6 ] do ] each
-12 [ [ [ 30 r ] times 90 flip petal6 ] do ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -1 2 -1 2 } >viewport
- 0.01 >threshold
- [ flower6 ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.game1-turn6
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: f-triangles ( -- )
- {
- [ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.80 b triangle ]
- [ 10 hue 0.9 sat 0.33 b triangle ]
- [ 0.9 s 10 hue 0.5 sat 1.00 b triangle ]
- [ 0.8 s 5 r f-triangles ]
- }
- rule ;
-
-: f-squares ( -- )
- {
- [ 0.1 x 0.1 y -0.33 alpha 250 hue 0.70 sat 0.80 b square ]
- [ 220 hue 0.90 sat 0.33 b square ]
- [ 0.9 s 220 hue 0.25 sat 1.00 b square ]
- [ 0.8 s 5 r f-squares ]
- }
- rule ;
-
-DEFER: start
-
-: spiral ( -- )
- {
- { 1 [ f-squares ]
- [ 0.5 x 0.5 y 45 r f-triangles ]
- [ 1 y 25 r 0.9 s spiral ] }
-
- { 0.022 [ 90 flip 50 hue start ] }
- }
- rules ;
-
-: start ( -- )
- [ spiral ] do
- [ 120 r spiral ] do
- [ 240 r spiral ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ 66 hue 0.4 sat 0.5 b ] >background
- { -5 10 -5 10 } >viewport
- 0.001 >threshold
- [ start ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.lesson
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: shapes ( -- )
-[ square ] do
-[ 0.3 b circle ] do
-[ 0.5 b triangle ] do
-[ 0.7 b 60 r triangle ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-1 ( -- )
-[ 2 x 5 y 3 size square ] do
-[ 6 x 5 y 3 size circle ] do
-[ 4 x 2 y 3 size triangle ] do
-[ 1 y 3 size shapes ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: foursquare ( -- )
-[ 0 x 0 y 5 3 size* square ] do
-[ 0 x 5 y 2 4 size* square ] do
-[ 5 x 5 y 3 size square ] do
-[ 5 x 0 y 2 size square ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-2 ( -- )
-[ square ] do
-[ 3 x 7 y square ] do
-[ 5 x 7 y 30 r square ] do
-[ 3 x 5 y 0.75 size square ] do
-[ 5 x 5 y 0.5 b square ] do
-[ 7 x 6 y 45 r 0.7 size 0.7 b square ] do
-[ 5 x 1 y 10 r 0.2 size foursquare ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: spiral ( -- )
-iterate? [
- [ 0.5 size circle ] do
- [ 0.2 y -3 r 0.995 size spiral ] do
-] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-3 ( -- ) [ 0 x 3 y spiral ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: tree
-
-: branch-left ( -- )
-{ { 1 [ 20 r tree ] }
- { 1 [ 30 r tree ] }
- { 1 [ 40 r tree ] }
- { 1 [ ] } } random-weighted* do ;
-
-: branch-right ( -- )
-{ { 1 [ -20 r tree ] }
- { 1 [ -30 r tree ] }
- { 1 [ -40 r tree ] }
- { 1 [ ] } } random-weighted* do ;
-
-: branch ( -- ) branch-left branch-right ;
-
-: tree ( -- )
-iterate? [
- {
- { 20 [ [ 0.25 size circle ] do
- [ 0.1 y 0.97 size tree ] do ] }
- { 1.5 [ branch ] }
- } random-weighted* do
-] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-4 ( -- )
-[ 1 x 0 y tree ] do
-[ 6 x 0 y tree ] do
-[ 1 x 4 y tree ] do
-[ 6 x 4 y tree ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: toc ( -- )
-[ 0 x 0 y chapter-1 ] do
-[ 10 x 0 y chapter-2 ] do
-[ 0 x -10 y chapter-3 ] do
-[ 10 x -10 y chapter-4 ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -5 25 -15 25 } >viewport
- 0.03 >threshold
- [ toc ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
-
+++ /dev/null
-
-USING: namespaces sequences math random-weighted cfdg ;
-
-IN: cfdg.models.rules08
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: insct ( -- )
- [ 1.5 5.5 size* -1 brightness triangle ] do
- 10
- [ [ [ 1 0.9 size* -0.15 y 0.05 brightness ] times 1 5 size* triangle ] do ]
- each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: line
-
-: ligne ( -- )
- {
- { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] }
- { 0.5 [ ] }
- }
- rules ;
-
-: line ( -- ) { [ insct ligne ] } rule ;
-
-: sole ( -- )
- {
- { 1 [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] }
- { 0.01 [ ] }
- }
- rules ;
-
-: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -1 b ] >background
- { -20 40 -20 40 } viewport set
- [ centre ] >start-shape
- 0.0001 >threshold ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.sierpinski
-
-: shape ( -- ) circle ;
-
-! : sierpinski ( -- )
-! iterate? [
-! shape
-! [ 0.6 s 5 r 0.2 b -1.5 y 0 x sierpinski ] do
-! [ 0.6 s 5 r -0.2 b 0.75 y -1.2990375 x sierpinski ] do
-! [ 0.6 s 5 r 0.75 y 1.2990375 x sierpinski ] do
-! ] when ;
-
-: sierpinski ( -- )
-iterate? [
- shape
- [ -1.5 y 0 x 0.6 s 5 r 0.2 b sierpinski ] do
- [ 0.75 y -1.2990375 x 0.6 s 5 r -0.2 b sierpinski ] do
- [ 0.75 y 1.2990375 x 0.6 s 5 r sierpinski ] do
-] when ;
-
-: top ( -- ) [ -13.5 r 0.5 b sierpinski ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -4 8 -4 8 } >viewport
- 0.01 >threshold
- [ top ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.snowflake
-
-: spike ( -- )
-iterate? [
- { { 1 [ square
- [ 0.95 y 0.97 s spike ] do ] }
- { 0.03 [ square
- [ 60 r spike ] do
- [ -60 r spike ] do
- [ 0.95 y 0.97 s spike ] do ] } }
- call-random-weighted
-] when ;
-
-: snowflake ( -- )
-spike
-[ 60 r spike ] do
-[ 120 r spike ] do
-[ 180 r spike ] do
-[ 240 r spike ] do
-[ 300 r spike ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -40 80 -40 80 } >viewport
- 0.1 >threshold
- [ snowflake ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
-
+++ /dev/null
-
-USING: namespaces sequences math random-weighted cfdg ;
-
-IN: cfdg.models.spirales
-
-DEFER: line
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: block ( -- ) { [ circle ] [ 0.3 s 60 flip line ] } rule ;
-
-: a1 ( -- ) { [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] [ block ] } rule ;
-
-: line ( -- ) -0.3 a { [ 0 r a1 ] [ 120 r a1 ] [ 240 r a1 ] } rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -1 b ] >background
- { -20 40 -20 40 } >viewport
- [ line ] >start-shape
- 0.04 >threshold ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Implementation of: http://contextfreeart.org
+++ /dev/null
-
-USING: kernel accessors locals math math.intervals math.order
- namespaces sequences threads
- ui
- ui.gadgets
- ui.gestures
- ui.render
- calendar
- multi-methods
- multi-method-syntax
- combinators.short-circuit.smart
- combinators.cleave.enhanced
- processing.shapes
- flatland ;
-
-IN: pong
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: clamp-to-interval ( x interval -- x )
- [ from>> first max ] [ to>> first min ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <play-field> < <rectangle> ;
-TUPLE: <paddle> < <rectangle> ;
-
-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? ]
- } && ;
-
-:: 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 -- )
-
-METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
-METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
- ! by multi-methods
-
-TUPLE: <pong> < gadget draw closed ;
-
-M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-M: <pong> draw-gadget* ( <pong> -- ) draw>> call ;
-M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-draw-closure ( -- closure )
-
- ! Establish some bindings
-
- [let | PLAY-FIELD [ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } ]
- BALL [ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } ]
-
- PLAYER [ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } ]
- COMPUTER [ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } ] |
-
- ! Define some internal words in terms of those bindings ...
-
- [wlet | align-player-with-mouse [ ( -- )
- PLAYER PLAY-FIELD align-paddle-with-mouse ]
-
- move-ball [ ( -- ) BALL 1 move-for ]
-
- player-blocked-ball? [ ( -- ? )
- BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
-
- computer-blocked-ball? [ ( -- ? )
- BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
-
- bounce-off-wall? [ ( -- ? )
- BALL PLAY-FIELD in-between-horizontally? not ] |
-
- ! Note, we're returning a quotation.
- ! The quotation closes over the bindings established by the 'let'.
- ! Thus the name of the word 'make-draw-closure'.
- ! This closure is intended to be placed in the 'draw' slot of a
- ! <pong> gadget.
-
- [
-
- BALL PLAY-FIELD in-bounds?
- [
- align-player-with-mouse
-
- move-ball
-
- ! computer reaction
-
- BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
- BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
-
- ! check if ball bounced off something
-
- player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
- computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
- bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
-
- ! draw the objects
-
- COMPUTER draw
- PLAYER draw
- BALL draw
-
- ]
- when
-
- ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
- ! The stack effects in the wlet expression throw
- ! off the effect for the whole word, so we reset
- ! it to the correct one here.
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: pong-loop-step ( PONG -- ? )
- PONG closed>>
- [ f ]
- [ PONG relayout-1 25 milliseconds sleep t ]
- if ;
-
-:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: play-pong ( -- )
-
- <pong> new-gadget
- make-draw-closure >>draw
- dup "PONG" open-window
-
- start-pong-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: play-pong-main ( -- ) [ play-pong ] with-ui ;
-
-MAIN: play-pong-main
\ No newline at end of file
projects / factor.git / commitdiff