steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-07-28 17:56:28 -05:00
parent 029e0e4bba 20ee2dd2a7
commit 1fe5774361
23 changed files with 221 additions and 258 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/boids/ui/ui.factor
View File

@ -41,7 +41,7 @@ IN: boids.ui
: draw-boids ( -- ) boids> [ draw-boid ] each ; : draw-boids ( -- ) boids> [ draw-boid ] each ;
: boid-color ( -- color ) { 1.0 0 0 0.3 } ; : boid-color ( -- color ) T{ rgba f 1.0 0 0 0.3 } ;
: display ( -- ) : display ( -- )
boid-color >fill-color boid-color >fill-color

3
extra/bubble-chamber/particle/axion/axion.factor
View File

@ -1,7 +1,8 @@
USING: kernel sequences random accessors multi-methods USING: kernel sequences random accessors multi-methods
math math.constants math.ranges math.points combinators.cleave math math.constants math.ranges math.points combinators.cleave
processing bubble-chamber.common bubble-chamber.particle ; processing processing.shapes
bubble-chamber.common bubble-chamber.particle ;
IN: bubble-chamber.particle.axion IN: bubble-chamber.particle.axion

7
extra/bubble-chamber/particle/hadron/hadron.factor
View File

@ -1,9 +1,8 @@
USING: kernel random math math.constants math.points accessors multi-methods USING: kernel random math math.constants math.points accessors multi-methods
processing processing processing.shapes
processing.color
bubble-chamber.common bubble-chamber.common
bubble-chamber.particle ; bubble-chamber.particle colors ;
IN: bubble-chamber.particle.hadron IN: bubble-chamber.particle.hadron
@ -26,7 +25,7 @@ METHOD: collide { hadron }
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
0 1 0 <rgb> >>myc 0 1 0 1 rgba boa >>myc
drop ; drop ;

2
extra/bubble-chamber/particle/muon/colors/colors.factor
View File

@ -1,7 +1,7 @@
USING: kernel sequences math math.constants math.order accessors USING: kernel sequences math math.constants math.order accessors
processing processing
processing.color ; colors ;
IN: bubble-chamber.particle.muon.colors IN: bubble-chamber.particle.muon.colors

1
extra/bubble-chamber/particle/muon/muon.factor
View File

@ -7,6 +7,7 @@ USING: kernel arrays sequences random
multi-methods accessors multi-methods accessors
combinators.cleave combinators.cleave
processing processing
processing.shapes
bubble-chamber.common bubble-chamber.common
bubble-chamber.particle bubble-chamber.particle
bubble-chamber.particle.muon.colors ; bubble-chamber.particle.muon.colors ;

8
extra/bubble-chamber/particle/particle.factor
View File

@ -1,8 +1,8 @@
USING: kernel sequences combinators USING: kernel sequences combinators
math math.vectors math.functions multi-methods math math.vectors math.functions multi-methods
accessors combinators.cleave processing processing.color accessors combinators.cleave processing
bubble-chamber.common ; bubble-chamber.common colors ;
IN: bubble-chamber.particle IN: bubble-chamber.particle
@ -28,8 +28,8 @@ TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
0 >>theta-d 0 >>theta-d
0 >>theta-dd 0 >>theta-dd
0 0 0 1 <rgba> >>myc 0 0 0 1 rgba boa >>myc
0 0 0 1 <rgba> >>mya ; 0 0 0 1 rgba boa >>mya ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/bubble-chamber/particle/quark/quark.factor
View File

@ -1,6 +1,6 @@
USING: kernel arrays sequences random math accessors multi-methods USING: kernel arrays sequences random math accessors multi-methods
processing processing processing.shapes
bubble-chamber.common bubble-chamber.common
bubble-chamber.particle ; bubble-chamber.particle ;

64
extra/colors/colors.factor
View File

@ -1,17 +1,55 @@
! Copyright (C) 2003, 2007 Slava Pestov. ! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators sequences arrays
classes.tuple multi-methods accessors colors.hsv ;
IN: colors IN: colors
: black { 0.0 0.0 0.0 1.0 } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: blue { 0.0 0.0 1.0 1.0 } ;
: cyan { 0 0.941 0.941 1 } ; TUPLE: color ;
: gray { 0.6 0.6 0.6 1.0 } ;
: green { 0.0 1.0 0.0 1.0 } ; TUPLE: rgba < color red green blue alpha ;
: light-gray { 0.95 0.95 0.95 0.95 } ;
: light-purple { 0.8 0.8 1.0 1.0 } ; TUPLE: hsva < color hue saturation value alpha ;
: magenta { 0.941 0 0.941 1 } ;
: orange { 0.941 0.627 0 1 } ; TUPLE: grey < color grey alpha ;
: purple { 0.627 0 0.941 1 } ;
: red { 1.0 0.0 0.0 1.0 } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: white { 1.0 1.0 1.0 1.0 } ;
: yellow { 1.0 1.0 0.0 1.0 } ; GENERIC: >rgba ( object -- rgba )
METHOD: >rgba { rgba } ;
METHOD: >rgba { hsva }
{ [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array
[ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ;
METHOD: >rgba { grey } [ grey>> dup dup ] [ alpha>> ] bi rgba boa ;
METHOD: >rgba { array } first4 rgba boa ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: syntax
M: color red>> >rgba red>> ;
M: color green>> >rgba green>> ;
M: color blue>> >rgba blue>> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: black T{ rgba f 0.0 0.0 0.0 1.0 } ;
: blue T{ rgba f 0.0 0.0 1.0 1.0 } ;
: cyan T{ rgba f 0 0.941 0.941 1 } ;
: gray T{ rgba f 0.6 0.6 0.6 1.0 } ;
: green T{ rgba f 0.0 1.0 0.0 1.0 } ;
: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ;
: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ;
: magenta T{ rgba f 0.941 0 0.941 1 } ;
: orange T{ rgba f 0.941 0.627 0 1 } ;
: purple T{ rgba f 0.627 0 0.941 1 } ;
: red T{ rgba f 1.0 0.0 0.0 1.0 } ;
: white T{ rgba f 1.0 1.0 1.0 1.0 } ;
: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ;

2
extra/golden-section/golden-section.factor
View File

@ -27,7 +27,7 @@ IN: golden-section
: radius ( i -- radius ) pi * 720 / sin 10 * ; : radius ( i -- radius ) pi * 720 / sin 10 * ;
: color ( i -- i ) dup 360.0 / dup 0.25 1 4array >fill-color ; : color ( i -- i ) dup 360.0 / dup 0.25 1 rgba boa >fill-color ;
: line-width ( i -- i ) dup radius 0.5 * 1 max glLineWidth ; : line-width ( i -- i ) dup radius 0.5 * 1 max glLineWidth ;

20
extra/opengl/opengl.factor
View File

@ -2,10 +2,12 @@
! Portions copyright (C) 2007 Eduardo Cavazos. ! Portions copyright (C) 2007 Eduardo Cavazos.
! Portions copyright (C) 2008 Joe Groff. ! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types continuations kernel libc math macros USING: alien alien.c-types continuations kernel libc math macros
namespaces math.vectors math.constants math.functions namespaces math.vectors math.constants math.functions
math.parser opengl.gl opengl.glu combinators arrays sequences math.parser opengl.gl opengl.glu combinators arrays sequences
splitting words byte-arrays assocs ; splitting words byte-arrays assocs colors accessors ;
IN: opengl IN: opengl
: coordinates ( point1 point2 -- x1 y2 x2 y2 ) : coordinates ( point1 point2 -- x1 y2 x2 y2 )
@ -14,6 +16,8 @@ IN: opengl
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
[ first2 [ >fixnum ] bi@ ] bi@ ; [ first2 [ >fixnum ] bi@ ] bi@ ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gl-color ( color -- ) first4 glColor4d ; inline : gl-color ( color -- ) first4 glColor4d ; inline
: gl-clear-color ( color -- ) : gl-clear-color ( color -- )
@ -22,6 +26,14 @@ IN: opengl
: gl-clear ( color -- ) : gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ; gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
: color>raw ( object -- r g b a )
>rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
: set-color ( object -- ) color>raw glColor4d ;
: set-clear-color ( object -- ) color>raw glClearColor ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gl-error ( -- ) : gl-error ( -- )
glGetError dup zero? [ glGetError dup zero? [
"GL error: " over gluErrorString append throw "GL error: " over gluErrorString append throw
@ -112,7 +124,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
GL_QUAD_STRIP [ GL_QUAD_STRIP [
swap >r prepare-gradient r> swap >r prepare-gradient r>
[ length dup 1- v/n ] keep [ [ length dup 1- v/n ] keep [
>r >r 2dup r> r> gl-color v*n >r >r 2dup r> r> set-color v*n
dup gl-vertex v+ gl-vertex dup gl-vertex v+ gl-vertex
] 2each 2drop ] 2each 2drop
] do-state ; ] do-state ;

2
extra/processing/gallery/trails/trails.factor
View File

@ -1,6 +1,6 @@
USING: kernel arrays sequences math math.order qualified USING: kernel arrays sequences math math.order qualified
sequences.lib circular processing ui newfx ; sequences.lib circular processing ui newfx processing.shapes ;
IN: processing.gallery.trails IN: processing.gallery.trails

266
extra/processing/processing.factor
View File

@ -9,8 +9,9 @@ USING: kernel namespaces threads combinators sequences arrays
combinators.lib combinators.lib
combinators.cleave combinators.cleave
rewrite-closures fry accessors newfx rewrite-closures fry accessors newfx
processing.color processing.gadget math.geometry.rect
processing.gadget math.geometry.rect ; processing.shapes
colors ;
IN: processing IN: processing
@ -36,53 +37,34 @@ IN: processing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: fill-color GENERIC: canonical-color-value ( obj -- color )
VAR: stroke-color
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! METHOD: canonical-color-value { number } dup dup 1 rgba boa ;
GENERIC: set-color ( value -- ) METHOD: canonical-color-value { array }
METHOD: set-color { number } dup dup glColor3d ;
METHOD: set-color { array }
dup length dup length
{ {
{ 2 [ first2 >r dup dup r> glColor4d ] } { 2 [ first2 >r dup dup r> rgba boa ] }
{ 3 [ first3 glColor3d ] } { 3 [ first3 1 rgba boa ] }
{ 4 [ first4 glColor4d ] } { 4 [ first4 rgba boa ] }
} }
case ; case ;
METHOD: set-color { rgba } ! METHOD: canonical-color-value { rgba }
{ [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ; ! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
METHOD: canonical-color-value { color } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fill ( value -- ) >fill-color ; : fill ( value -- ) canonical-color-value >fill-color ;
: stroke ( value -- ) >stroke-color ; : stroke ( value -- ) canonical-color-value >stroke-color ;
: no-fill ( -- ) ! : no-fill ( -- ) 0 fill-color> set-fourth ;
fill-color> ! : no-stroke ( -- ) 0 stroke-color> set-fourth ;
{
{ [ dup number? ] [ 0 2array fill ] }
{ [ t ]
[
[ drop 0 ] [ length 1- ] [ ] tri set-nth
] }
}
cond ;
: no-stroke ( -- ) : no-fill ( -- ) fill-color> 0 >>alpha drop ;
stroke-color> : no-stroke ( -- ) stroke-color> 0 >>alpha drop ;
{
{ [ dup number? ] [ 0 2array stroke ] }
{ [ t ]
[
[ drop 0 ] [ length 1- ] [ ] tri set-nth
] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -90,167 +72,93 @@ METHOD: set-color { rgba }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: point* ( x y -- ) ! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
stroke-color> set-color ! GL_POLYGON glBegin
GL_POINTS glBegin ! glVertex2d
glVertex2d ! glVertex2d
glEnd ; ! glVertex2d
! glVertex2d
! glEnd ;
: point ( seq -- ) first2 point* ; ! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
: line ( x1 y1 x2 y2 -- ) ! 8 ndup
stroke-color> set-color
GL_LINES glBegin
glVertex2d
glVertex2d
glEnd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
! fill-color> set-color
: triangle ( x1 y1 x2 y2 x3 y3 -- ) ! quad-vertices
GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> set-color
6 ndup
GL_TRIANGLES glBegin ! GL_FRONT_AND_BACK GL_LINE glPolygonMode
glVertex2d ! stroke-color> set-color
glVertex2d
glVertex2d
glEnd
GL_FRONT_AND_BACK GL_LINE glPolygonMode ! quad-vertices ;
stroke-color> set-color
GL_TRIANGLES glBegin
glVertex2d
glVertex2d
glVertex2d
glEnd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) ! : ellipse-disk ( x y width height -- )
GL_POLYGON glBegin ! glPushMatrix
glVertex2d ! >r >r
glVertex2d ! 0 glTranslated
glVertex2d ! r> r> 1 glScaled
glVertex2d ! gluNewQuadric
glEnd ; ! dup 0 0.5 20 1 gluDisk
! gluDeleteQuadric
! glPopMatrix ;
: quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) ! : ellipse-center ( x y width height -- )
8 ndup ! 4dup
GL_FRONT_AND_BACK GL_FILL glPolygonMode ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> set-color ! stroke-color> set-color
quad-vertices ! ellipse-disk
GL_FRONT_AND_BACK GL_LINE glPolygonMode
stroke-color> set-color
quad-vertices ; ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
! fill-color> set-color
! [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
! ellipse-disk ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rect-vertices ( x y width height -- ) ! SYMBOL: CENTER
GL_POLYGON glBegin ! SYMBOL: RADIUS
[ 2drop glVertex2d ] 4keep ! SYMBOL: CORNER
[ drop swap >r + 1- r> glVertex2d ] 4keep ! SYMBOL: CORNERS
[ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep
[ nip + 1- glVertex2d ] 4keep
4drop
glEnd ;
: rect ( x y width height -- ) ! SYMBOL: ellipse-mode-value
4dup ! : ellipse-mode ( val -- ) ellipse-mode-value set ;
GL_FRONT_AND_BACK GL_FILL glPolygonMode ! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
fill-color> set-color
rect-vertices ! : ellipse-corner ( x y width height -- )
! [ drop nip 2 / + ] 4keep
! [ nip rot drop 2 / + ] 4keep
! [ >r >r 2drop r> r> ] 4keep
! 4drop
! ellipse-center ;
GL_FRONT_AND_BACK GL_LINE glPolygonMode ! : ellipse-corners ( x1 y1 x2 y2 -- )
stroke-color> set-color ! [ drop nip + 2 / ] 4keep
! [ nip rot drop + 2 / ] 4keep
! [ drop nip - abs 1+ ] 4keep
! [ nip rot drop - abs 1+ ] 4keep
! 4drop
! ellipse-center ;
rect-vertices ; ! : ellipse ( a b c d -- )
! ellipse-mode-value get
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! {
! { CENTER [ ellipse-center ] }
: ellipse-disk ( x y width height -- ) ! { RADIUS [ ellipse-radius ] }
glPushMatrix ! { CORNER [ ellipse-corner ] }
>r >r ! { CORNERS [ ellipse-corners ] }
0 glTranslated ! }
r> r> 1 glScaled ! case ;
gluNewQuadric
dup 0 0.5 20 1 gluDisk
gluDeleteQuadric
glPopMatrix ;
: ellipse-center ( x y width height -- )
4dup
GL_FRONT_AND_BACK GL_FILL glPolygonMode
stroke-color> set-color
ellipse-disk
GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> set-color
[ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
ellipse-disk ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: CENTER
SYMBOL: RADIUS
SYMBOL: CORNER
SYMBOL: CORNERS
SYMBOL: ellipse-mode-value
: ellipse-mode ( val -- ) ellipse-mode-value set ;
: ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
: ellipse-corner ( x y width height -- )
[ drop nip 2 / + ] 4keep
[ nip rot drop 2 / + ] 4keep
[ >r >r 2drop r> r> ] 4keep
4drop
ellipse-center ;
: ellipse-corners ( x1 y1 x2 y2 -- )
[ drop nip + 2 / ] 4keep
[ nip rot drop + 2 / ] 4keep
[ drop nip - abs 1+ ] 4keep
[ nip rot drop - abs 1+ ] 4keep
4drop
ellipse-center ;
: ellipse ( a b c d -- )
ellipse-mode-value get
{
{ CENTER [ ellipse-center ] }
{ RADIUS [ ellipse-radius ] }
{ CORNER [ ellipse-corner ] }
{ CORNERS [ ellipse-corners ] }
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: multi-methods ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -279,8 +187,8 @@ METHOD: background { array }
: mouse ( -- point ) hand-loc get ; : mouse ( -- point ) hand-loc get ;
: mouse-x mouse first ; : mouse-x ( -- x ) mouse first ;
: mouse-y mouse second ; : mouse-y ( -- y ) mouse second ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -296,9 +204,7 @@ VAR: loop-flag
: defaults ( -- ) : defaults ( -- )
0.8 background 0.8 background
0 >stroke-color ! CENTER ellipse-mode
1 >fill-color
CENTER ellipse-mode
60 frame-rate ; 60 frame-rate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

14
extra/processing/shapes/shapes.factor
View File

@ -3,7 +3,7 @@ USING: kernel namespaces arrays sequences grouping
alien.c-types alien.c-types
math math.vectors math.geometry.rect math math.vectors math.geometry.rect
opengl.gl opengl.glu opengl generalizations vars opengl.gl opengl.glu opengl generalizations vars
combinators.cleave ; combinators.cleave colors ;
IN: processing.shapes IN: processing.shapes
@ -12,20 +12,20 @@ IN: processing.shapes
VAR: fill-color VAR: fill-color
VAR: stroke-color VAR: stroke-color
{ 0 0 0 1 } stroke-color set-global T{ rgba f 0 0 0 1 } stroke-color set-global
{ 1 1 1 1 } fill-color set-global T{ rgba f 1 1 1 1 } fill-color set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fill-mode ( -- ) : fill-mode ( -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> gl-color ; fill-color> set-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: stroke-mode ( -- ) : stroke-mode ( -- )
GL_FRONT_AND_BACK GL_LINE glPolygonMode GL_FRONT_AND_BACK GL_LINE glPolygonMode
stroke-color> gl-color ; stroke-color> set-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -101,8 +101,8 @@ VAR: stroke-color
: ellipse ( center dim -- ) : ellipse ( center dim -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode GL_FRONT_AND_BACK GL_FILL glPolygonMode
[ stroke-color> gl-color gl-ellipse ] [ stroke-color> set-color gl-ellipse ]
[ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ; [ fill-color> set-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

13
extra/slides/slides.factor
View File

@ -23,14 +23,14 @@ IN: slides
H{ H{
{ font "monospace" } { font "monospace" }
{ font-size 36 } { font-size 36 }
{ page-color { 0.4 0.4 0.4 0.3 } } { page-color T{ rgba f 0.4 0.4 0.4 0.3 } }
} }
} }
{ snippet-style { snippet-style
H{ H{
{ font "monospace" } { font "monospace" }
{ font-size 36 } { font-size 36 }
{ foreground { 0.1 0.1 0.4 1 } } { foreground T{ rgba f 0.1 0.1 0.4 1 } }
} }
} }
{ table-content-style { table-content-style
@ -48,14 +48,19 @@ IN: slides
: $divider ( -- ) : $divider ( -- )
[ [
<gadget> <gadget>
T{ gradient f { { 0.25 0.25 0.25 1.0 } { 1.0 1.0 1.0 0.0 } } } >>interior T{ gradient f
{
T{ rgba f 0.25 0.25 0.25 1.0 }
T{ rgba f 1.0 1.0 1.0 0.0 }
}
} >>interior
{ 800 10 } >>dim { 800 10 } >>dim
{ 1 0 } >>orientation { 1 0 } >>orientation
gadget. gadget.
] ($block) ; ] ($block) ;
: page-theme ( gadget -- ) : page-theme ( gadget -- )
T{ gradient f { { 0.8 0.8 1.0 1.0 } { 0.8 1.0 1.0 1.0 } } } T{ gradient f { T{ rgba f 0.8 0.8 1.0 1.0 } T{ rgba f 0.8 1.0 1.0 1.0 } } }
swap set-gadget-interior ; swap set-gadget-interior ;
: <page> ( list -- gadget ) : <page> ( list -- gadget )

6
extra/ui/gadgets/buttons/buttons.factor
View File

@ -106,7 +106,7 @@ TUPLE: checkmark-paint color ;
C: <checkmark-paint> checkmark-paint C: <checkmark-paint> checkmark-paint
M: checkmark-paint draw-interior M: checkmark-paint draw-interior
checkmark-paint-color gl-color checkmark-paint-color set-color
origin get [ origin get [
rect-dim rect-dim
{ 0 0 } over gl-line { 0 0 } over gl-line
@ -152,11 +152,11 @@ TUPLE: radio-paint color ;
C: <radio-paint> radio-paint C: <radio-paint> radio-paint
M: radio-paint draw-interior M: radio-paint draw-interior
radio-paint-color gl-color radio-paint-color set-color
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ; origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
M: radio-paint draw-boundary M: radio-paint draw-boundary
radio-paint-color gl-color radio-paint-color set-color
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ; origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
: radio-knob-theme ( gadget -- ) : radio-knob-theme ( gadget -- )

6
extra/ui/gadgets/editors/editors.factor
View File

@ -129,7 +129,7 @@ M: editor ungraft*
: draw-caret ( -- ) : draw-caret ( -- )
editor get editor-focused? [ editor get editor-focused? [
editor get editor get
dup editor-caret-color gl-color dup editor-caret-color set-color
dup caret-loc origin get v+ dup caret-loc origin get v+
swap caret-dim over v+ swap caret-dim over v+
[ { 0.5 -0.5 } v+ ] bi@ gl-line [ { 0.5 -0.5 } v+ ] bi@ gl-line
@ -173,7 +173,7 @@ M: editor ungraft*
: draw-lines ( -- ) : draw-lines ( -- )
\ first-visible-line get [ \ first-visible-line get [
editor get dup editor-color gl-color editor get dup editor-color set-color
dup visible-lines dup visible-lines
[ draw-line 1 translate-lines ] with each [ draw-line 1 translate-lines ] with each
] with-editor-translation ; ] with-editor-translation ;
@ -192,7 +192,7 @@ M: editor ungraft*
(draw-selection) ; (draw-selection) ;
: draw-selection ( -- ) : draw-selection ( -- )
editor get editor-selection-color gl-color editor get editor-selection-color set-color
editor get selection-start/end editor get selection-start/end
over first [ over first [
2dup [ 2dup [

2
extra/ui/gadgets/grid-lines/grid-lines.factor
View File

@ -25,7 +25,7 @@ SYMBOL: grid-dim
M: grid-lines draw-boundary M: grid-lines draw-boundary
origin get [ origin get [
-0.5 -0.5 0.0 glTranslated -0.5 -0.5 0.0 glTranslated
grid-lines-color gl-color [ grid-lines-color set-color [
dup grid set dup grid set
dup rect-dim half-gap v- grid-dim set dup rect-dim half-gap v- grid-dim set
compute-grid compute-grid

4
extra/ui/gadgets/labelled/labelled.factor
View File

@ -31,8 +31,8 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
: title-theme ( gadget -- ) : title-theme ( gadget -- )
{ 1 0 } over set-gadget-orientation { 1 0 } over set-gadget-orientation
T{ gradient f { T{ gradient f {
{ 0.65 0.65 1.0 1.0 } T{ rgba f 0.65 0.65 1.0 1.0 }
{ 0.65 0.45 1.0 1.0 } T{ rgba f 0.65 0.45 1.0 1.0 }
} } swap set-gadget-interior ; } } swap set-gadget-interior ;
: <title-label> ( text -- label ) <label> dup title-theme ; : <title-label> ( text -- label ) <label> dup title-theme ;

2
extra/ui/gadgets/labels/labels.factor
View File

@ -35,7 +35,7 @@ M: label pref-dim*
[ font>> open-font ] [ text>> ] bi text-dim ; [ font>> open-font ] [ text>> ] bi text-dim ;
M: label draw-gadget* M: label draw-gadget*
[ color>> gl-color ] [ color>> set-color ]
[ [ font>> ] [ text>> ] bi origin get draw-text ] bi ; [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
M: label gadget-text* label-string % ; M: label gadget-text* label-string % ;

7
extra/ui/gadgets/lists/lists.factor
View File

@ -4,13 +4,14 @@ USING: accessors ui.commands ui.gestures ui.render ui.gadgets
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.labels ui.gadgets.scrollers
kernel sequences models opengl math math.order namespaces kernel sequences models opengl math math.order namespaces
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
math.vectors classes.tuple math.geometry.rect ; math.vectors classes.tuple math.geometry.rect colors ;
IN: ui.gadgets.lists IN: ui.gadgets.lists
TUPLE: list < pack index presenter color hook ; TUPLE: list < pack index presenter color hook ;
: list-theme ( list -- list ) : list-theme ( list -- list )
{ 0.8 0.8 1.0 1.0 } >>color ; inline T{ rgba f 0.8 0.8 1.0 1.0 } >>color ; inline
: <list> ( hook presenter model -- gadget ) : <list> ( hook presenter model -- gadget )
list new-gadget list new-gadget
@ -56,7 +57,7 @@ M: list model-changed
M: list draw-gadget* M: list draw-gadget*
origin get [ origin get [
dup list-color gl-color dup list-color set-color
selected-rect [ rect-extent gl-fill-rect ] when* selected-rect [ rect-extent gl-fill-rect ] when*
] with-translation ; ] with-translation ;

2
extra/ui/gadgets/panes/panes.factor
View File

@ -68,7 +68,7 @@ M: node draw-selection ( loc node -- )
M: pane draw-gadget* M: pane draw-gadget*
dup gadget-selection? [ dup gadget-selection? [
dup pane-selection-color gl-color dup pane-selection-color set-color
origin get over rect-loc v- swap selected-children origin get over rect-loc v- swap selected-children
[ draw-selection ] with each [ draw-selection ] with each
] [ ] [

38
extra/ui/gadgets/theme/theme.factor
View File

@ -18,41 +18,41 @@ IN: ui.gadgets.theme
: plain-gradient : plain-gradient
T{ gradient f { T{ gradient f {
{ 0.94 0.94 0.94 1.0 } T{ rgba f 0.94 0.94 0.94 1.0 }
{ 0.83 0.83 0.83 1.0 } T{ rgba f 0.83 0.83 0.83 1.0 }
{ 0.83 0.83 0.83 1.0 } T{ rgba f 0.83 0.83 0.83 1.0 }
{ 0.62 0.62 0.62 1.0 } T{ rgba f 0.62 0.62 0.62 1.0 }
} } ; } } ;
: rollover-gradient : rollover-gradient
T{ gradient f { T{ gradient f {
{ 1.0 1.0 1.0 1.0 } T{ rgba f 1.0 1.0 1.0 1.0 }
{ 0.9 0.9 0.9 1.0 } T{ rgba f 0.9 0.9 0.9 1.0 }
{ 0.9 0.9 0.9 1.0 } T{ rgba f 0.9 0.9 0.9 1.0 }
{ 0.75 0.75 0.75 1.0 } T{ rgba f 0.75 0.75 0.75 1.0 }
} } ; } } ;
: pressed-gradient : pressed-gradient
T{ gradient f { T{ gradient f {
{ 0.75 0.75 0.75 1.0 } T{ rgba f 0.75 0.75 0.75 1.0 }
{ 0.9 0.9 0.9 1.0 } T{ rgba f 0.9 0.9 0.9 1.0 }
{ 0.9 0.9 0.9 1.0 } T{ rgba f 0.9 0.9 0.9 1.0 }
{ 1.0 1.0 1.0 1.0 } T{ rgba f 1.0 1.0 1.0 1.0 }
} } ; } } ;
: selected-gradient : selected-gradient
T{ gradient f { T{ gradient f {
{ 0.65 0.65 0.65 1.0 } T{ rgba f 0.65 0.65 0.65 1.0 }
{ 0.8 0.8 0.8 1.0 } T{ rgba f 0.8 0.8 0.8 1.0 }
{ 0.8 0.8 0.8 1.0 } T{ rgba f 0.8 0.8 0.8 1.0 }
{ 1.0 1.0 1.0 1.0 } T{ rgba f 1.0 1.0 1.0 1.0 }
} } ; } } ;
: lowered-gradient : lowered-gradient
T{ gradient f { T{ gradient f {
{ 0.37 0.37 0.37 1.0 } T{ rgba f 0.37 0.37 0.37 1.0 }
{ 0.43 0.43 0.43 1.0 } T{ rgba f 0.43 0.43 0.43 1.0 }
{ 0.5 0.5 0.5 1.0 } T{ rgba f 0.5 0.5 0.5 1.0 }
} } ; } } ;
: sans-serif-font { "sans-serif" plain 12 } ; : sans-serif-font { "sans-serif" plain 12 } ;

6
extra/ui/render/render.factor
View File

@ -35,7 +35,7 @@ SYMBOL: viewport-translation
init-clip init-clip
! white gl-clear is broken w.r.t window resizing ! white gl-clear is broken w.r.t window resizing
! Linux/PPC Radeon 9200 ! Linux/PPC Radeon 9200
white gl-color white set-color
clip get rect-extent gl-fill-rect ; clip get rect-extent gl-fill-rect ;
GENERIC: draw-gadget* ( gadget -- ) GENERIC: draw-gadget* ( gadget -- )
@ -95,7 +95,7 @@ C: <solid> solid
! Solid pen ! Solid pen
: (solid) ( gadget paint -- loc dim ) : (solid) ( gadget paint -- loc dim )
solid-color gl-color rect-dim >r origin get dup r> v+ ; solid-color set-color rect-dim >r origin get dup r> v+ ;
M: solid draw-interior (solid) gl-fill-rect ; M: solid draw-interior (solid) gl-fill-rect ;
@ -121,7 +121,7 @@ C: <polygon> polygon
: draw-polygon ( polygon quot -- ) : draw-polygon ( polygon quot -- )
origin get [ origin get [
>r dup polygon-color gl-color polygon-points r> call >r dup polygon-color set-color polygon-points r> call
] with-translation ; inline ] with-translation ; inline
M: polygon draw-boundary M: polygon draw-boundary