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

extra/boids/ui/ui.factor

@@ -41,7 +41,7 @@ IN: boids.ui
 
 : 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 ( -- )
   boid-color >fill-color

extra/bubble-chamber/particle/hadron/hadron.factor

@@ -1,9 +1,8 @@
 
 USING: kernel random math math.constants math.points accessors multi-methods
        processing processing.shapes
-       processing.color
        bubble-chamber.common
-       bubble-chamber.particle ;
+       bubble-chamber.particle colors ;
 
 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 1 0 <rgb> >>myc
+  0 1 0 1 rgba boa >>myc
 
   drop ;
 

extra/bubble-chamber/particle/muon/colors/colors.factor

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

extra/bubble-chamber/particle/particle.factor

@@ -1,8 +1,8 @@
 
 USING: kernel sequences combinators
        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
 
@@ -28,8 +28,8 @@ TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
   0 >>theta-d
   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 ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/colors/colors.factor

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

extra/golden-section/golden-section.factor

@@ -27,7 +27,7 @@ IN: golden-section
 
 : 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 ;
 

extra/opengl/opengl.factor

@@ -16,7 +16,7 @@ IN: opengl
 : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
     [ first2 [ >fixnum ] bi@ ] bi@ ;
 
-
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : gl-color ( color -- ) first4 glColor4d ; inline
 
@@ -26,15 +26,13 @@ IN: opengl
 : gl-clear ( color -- )
     gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
 
-: color>raw ( object -- 4array )
+: color>raw ( object -- r g b a )
-  >rgba
+  >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
-    { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave
-  4array ;
-
-: set-color       ( object -- ) color>raw first4 glColor4d ;
-: set-clear-color ( object -- ) color>raw first4 glClearColor ;
 
+: set-color       ( object -- ) color>raw glColor4d ;
+: set-clear-color ( object -- ) color>raw glClearColor ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : gl-error ( -- )
     glGetError dup zero? [
@@ -126,7 +124,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
     GL_QUAD_STRIP [
         swap >r prepare-gradient r>
         [ 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
         ] 2each 2drop
     ] do-state ;

extra/processing/processing.factor

@@ -9,9 +9,9 @@ USING: kernel namespaces threads combinators sequences arrays
        combinators.lib
        combinators.cleave
        rewrite-closures fry accessors newfx
-       processing.color
        processing.gadget math.geometry.rect
-       processing.shapes ;
+       processing.shapes
+       colors ;
        
 IN: processing
 
@@ -39,27 +39,32 @@ IN: processing
 
 GENERIC: canonical-color-value ( obj -- color )
 
-METHOD: canonical-color-value { number } dup dup 1 4array ;
+METHOD: canonical-color-value { number } dup dup 1 rgba boa ;
 
 METHOD: canonical-color-value { array }
    dup length
    {
-     { 2 [ first2 >r dup dup r> 4array ] }
+     { 2 [ first2 >r dup dup r> rgba boa ] }
-     { 3 [ 1 suffix ] }
+     { 3 [ first3 1             rgba boa ] }
-     { 4 [ ] }
+     { 4 [ first4               rgba boa ] }
    }
    case ;
 
-METHOD: canonical-color-value { rgba }
+! METHOD: canonical-color-value { rgba }
-  { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
+!   { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
+
+METHOD: canonical-color-value { color } ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : fill   ( value -- ) canonical-color-value >fill-color   ;
 : stroke ( value -- ) canonical-color-value >stroke-color ;
 
-: no-fill   ( -- ) 0 fill-color>   set-fourth ;
+! : no-fill   ( -- ) 0 fill-color>   set-fourth ;
-: no-stroke ( -- ) 0 stroke-color> set-fourth ;
+! : no-stroke ( -- ) 0 stroke-color> set-fourth ;
+
+: no-fill   ( -- ) fill-color>   0 >>alpha drop ;
+: no-stroke ( -- ) stroke-color> 0 >>alpha drop ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/processing/shapes/shapes.factor

@@ -3,7 +3,7 @@ USING: kernel namespaces arrays sequences grouping
        alien.c-types
        math math.vectors math.geometry.rect
        opengl.gl opengl.glu opengl generalizations vars
-       combinators.cleave  ;
+       combinators.cleave colors ;
 
 IN: processing.shapes
 
@@ -12,20 +12,20 @@ IN: processing.shapes
 VAR: fill-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 ( -- )
   GL_FRONT_AND_BACK GL_FILL glPolygonMode
-  fill-color> gl-color ;
+  fill-color> set-color ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : stroke-mode ( -- )
   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 -- )
   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 ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/slides/slides.factor

@@ -23,14 +23,14 @@ IN: slides
             H{
                 { font "monospace" }
                 { 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
             H{
                 { font "monospace" }
                 { 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
@@ -48,14 +48,19 @@ IN: slides
 : $divider ( -- )
     [
         <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
         { 1 0 } >>orientation
         gadget.
     ] ($block) ;
 
 : 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 ;
 
 : <page> ( list -- gadget )

extra/ui/gadgets/buttons/buttons.factor

@@ -106,7 +106,7 @@ TUPLE: checkmark-paint color ;
 C: <checkmark-paint> checkmark-paint
 
 M: checkmark-paint draw-interior
-    checkmark-paint-color gl-color
+    checkmark-paint-color set-color
     origin get [
         rect-dim
         { 0 0 } over gl-line
@@ -152,11 +152,11 @@ TUPLE: radio-paint color ;
 C: <radio-paint> radio-paint
 
 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 ;
 
 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 ;
 
 : radio-knob-theme ( gadget -- )

extra/ui/gadgets/editors/editors.factor

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

extra/ui/gadgets/grid-lines/grid-lines.factor

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

extra/ui/gadgets/labelled/labelled.factor

@@ -31,8 +31,8 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
 : title-theme ( gadget -- )
     { 1 0 } over set-gadget-orientation
     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 ;
 
 : <title-label> ( text -- label ) <label> dup title-theme ;

extra/ui/gadgets/labels/labels.factor

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

extra/ui/gadgets/lists/lists.factor

@@ -4,13 +4,14 @@ USING: accessors ui.commands ui.gestures ui.render ui.gadgets
 ui.gadgets.labels ui.gadgets.scrollers
 kernel sequences models opengl math math.order namespaces
 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
 
 TUPLE: list < pack index presenter color hook ;
 
 : 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 new-gadget
@@ -56,7 +57,7 @@ M: list model-changed
 
 M: list draw-gadget*
     origin get [
-        dup list-color gl-color
+        dup list-color set-color
         selected-rect [ rect-extent gl-fill-rect ] when*
     ] with-translation ;
 

extra/ui/gadgets/panes/panes.factor

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

extra/ui/gadgets/theme/theme.factor

@@ -18,41 +18,41 @@ IN: ui.gadgets.theme
 
 : plain-gradient
     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
     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
     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
     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
     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 } ;

extra/ui/render/render.factor

@@ -35,7 +35,7 @@ SYMBOL: viewport-translation
     init-clip
     ! white gl-clear is broken w.r.t window resizing
     ! Linux/PPC Radeon 9200
-    white gl-color
+    white set-color
     clip get rect-extent gl-fill-rect ;
 
 GENERIC: draw-gadget* ( gadget -- )
@@ -95,7 +95,7 @@ C: <solid> solid
 
 ! Solid pen
 : (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 ;
 
@@ -121,7 +121,7 @@ C: <polygon> polygon
 
 : draw-polygon ( polygon quot -- )
     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
 
 M: polygon draw-boundary