Merge commit 'dharmatech/master' into new_representations

extra/bake/bake.factor

@@ -48,5 +48,4 @@ DEFER: bake
 : bake-items ( seq -- ) [ bake-item ] each ;
 
 : bake ( seq -- seq )
-  [ reset-building save-exemplar bake-items finish-baking ] with-scope ;
-
+  [ reset-building save-exemplar bake-items finish-baking ] with-scope ;

extra/benchmark/mandel/mandel.factor

@@ -19,8 +19,8 @@ math.functions math.parser io.files colors.hsv ;
 
 : <color-map> ( nb-cols -- map )
     dup [
-        360 * swap 1+ / 360 / sat val
-        hsv>rgb scale-rgb
+        360 * swap 1+ / sat val
+        3array hsv>rgb first3 scale-rgb
     ] curry* map ;
 
 : iter ( c z nb-iter -- x )

extra/cfdg/cfdg.factor

@@ -2,36 +2,43 @@
 USING: kernel alien.c-types combinators namespaces arrays
        sequences sequences.lib namespaces.lib splitting
        math math.functions math.vectors math.trig
-       opengl.gl opengl.glu ui ui.gadgets.slate vars mortar slot-accessors
-       random-weighted cfdg.hsv cfdg.gl ;
+       opengl.gl opengl.glu opengl ui ui.gadgets.slate
+       combinators.lib vars
+       random-weighted colors.hsv cfdg.gl ;
 
 IN: cfdg
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-SYMBOL: <hsba>
+! hsba { hue saturation brightness alpha }
 
-<hsba>
-  { "hue" "saturation" "brightness" "alpha" } accessors
-define-independent-class
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hsv>rgb* ( h s v -- r g b ) 3array hsv>rgb first3 ;
-
-: gl-set-hsba ( color -- ) object-values first4 >r hsv>rgb* r> glColor4d ;
-
-: gl-clear-hsba ( color -- ) object-values first4 >r hsv>rgb* r> glClearColor ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: <hsba> 4array ;
 
 VAR: color
 
-: init-color ( -- ) 0 0 0 1 <hsba> new >color ;
+! ( -- val )
 
-: hue ( num -- ) color> tuck $hue + 360 mod >>hue drop ;
+: hue>>        0 color> nth ;
+: saturation>> 1 color> nth ;
+: brightness>> 2 color> nth ;
+: alpha>>      3 color> nth ;
 
-: h ( num -- ) hue ;
+! ( val -- )
+
+: >>hue        0 color> set-nth ;
+: >>saturation 1 color> set-nth ;
+: >>brightness 2 color> set-nth ;
+: >>alpha      3 color> set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi add ;
+
+: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ;
+
+: gl-clear-hsba ( hsva -- ) hsva>rgba gl-clear ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 ! if (adjustment < 0)
 !   base + base * adjustment
@@ -41,17 +48,20 @@ VAR: color
 
 : adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ;
 
-: saturation ( num -- ) color> dup $saturation rot adjust >>saturation drop ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: sat ( num -- ) saturation ;
+: hue ( num -- ) hue>> + 360 mod >>hue ;
 
-: brightness ( num -- ) color> dup $brightness rot adjust >>brightness drop ;
+: saturation ( num -- ) saturation>> swap adjust >>saturation ;
+: brightness ( num -- ) brightness>> swap adjust >>brightness ;
+: alpha      ( num -- ) alpha>>      swap adjust >>alpha ;
 
-: b ( num -- ) brightness ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: alpha ( num -- ) color> dup $alpha rot adjust >>alpha drop ;
-
-: a ( num -- ) alpha ;
+: h   hue ;
+: sat saturation ;
+: b   brightness ;
+: a   alpha ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -59,38 +69,19 @@ VAR: color-stack
 
 : init-color-stack ( -- ) V{ } clone >color-stack ;
 
-: clone-color ( hsba -- hsba ) object-values first4 <hsba> new ;
-
-: push-color ( -- )
-color> color-stack> push
-color> clone-color >color ;
+: push-color ( -- ) color> color-stack> push   color> clone >color ;
 
 : pop-color ( -- ) color-stack> pop dup >color gl-set-hsba ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! : check-size ( modelview-matrix -- num )
-! { 0 1 4 5 } swap [ double-nth ] curry map
-! [ abs ] map
-! [ <=> ] maximum ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : check-size ( modelview-matrix -- num )
-!   { 0 1 4 5 } swap [ double-nth ] curry map
-!   [ abs ] map
-!   biggest ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
 
-: check-size ( modelview-matrix -- num )
-  { 0 1 4 5 } double-nth* [ abs ] map biggest ;
+: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ;
 
 VAR: threshold
 
-: iterate? ( -- ? ) get-modelview-matrix check-size threshold get > ;
+: iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -101,65 +92,65 @@ VAR: threshold
 
 ! column major order
 
-: gl-flip ( angle -- ) deg>rad
-{ [ dup 2 * cos ] [ dup 2 * sin ] 0 0
-  [ dup 2 * sin ] [ 2 * cos neg ] 0 0
-  0 0 1 0
-  0 0 0 1 } make* >c-double-array glMultMatrixd ;
+: 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 , ]
+  { } make >c-double-array glMultMatrixd ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : circle ( -- )
-color> gl-set-hsba
-gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
+  color> gl-set-hsba
+  gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
 
 : triangle ( -- )
-color> gl-set-hsba
-GL_POLYGON glBegin
-   0    0.577 glVertex2d
-   0.5 -0.289 glVertex2d
-  -0.5 -0.289 glVertex2d
-glEnd ;
+  color> gl-set-hsba
+  GL_POLYGON glBegin
+    0    0.577 glVertex2d
+    0.5 -0.289 glVertex2d
+   -0.5 -0.289 glVertex2d
+  glEnd ;
 
 : square ( -- )
-color> gl-set-hsba
-GL_POLYGON glBegin
-  -0.5  0.5 glVertex2d
-   0.5  0.5 glVertex2d
-   0.5 -0.5 glVertex2d
-  -0.5 -0.5 glVertex2d
-glEnd ;
+  color> gl-set-hsba
+  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 ;
 
-: s ( scale -- ) size ;
-
 : size* ( scale-x scale-y -- ) 1 glScaled ;
 
-: s* ( scale-x scale-y -- ) size* ;
-
 : rotate ( angle -- ) 0 0 1 glRotated ;
 
-: r ( angle -- ) rotate ;
-
 : x ( x -- ) 0 0 glTranslated ;
 
 : y ( y -- ) 0 swap 0 glTranslated ;
 
 : flip ( angle -- ) gl-flip ;
 
-: f ( angle -- ) flip ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: s  size ;
+: s* size* ;
+: r  rotate ;
+: f  flip ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : do ( quot -- )
-push-modelview-matrix
-push-color
-call
-pop-modelview-matrix
-pop-color ;
+  push-modelview-matrix
+  push-color
+  call
+  pop-modelview-matrix
+  pop-color ; inline
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -171,10 +162,10 @@ pop-color ;
 
 VAR: background
 
-: initial-background ( -- hsba ) 0 0 1 1 <hsba> new ;
+: set-initial-background ( -- ) { 0 0 1 1 } clone >color ;
 
 : set-background ( -- )
-  initial-background >color
+  set-initial-background
   background> call
   color> gl-clear-hsba ;
 
@@ -186,23 +177,10 @@ VAR: viewport ! { left width bottom height }
 
 VAR: start-shape
 
-: initial-color ( -- hsba ) 0 0 0 1 <hsba> new ;
+: set-initial-color ( -- ) { 0 0 0 1 } clone >color ;
 
 : display ( -- )
 
-!   GL_LINE_SMOOTH glEnable
-!   GL_BLEND glEnable
-!   GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
-!   GL_POINT_SMOOTH_HINT GL_NICEST glHint
-
-!   GL_FOG glEnable
-!   GL_FOG_MODE GL_LINEAR glFogi
-!   GL_FOG_COLOR { 0.5 0.5 0.5 1.0 } >c-double-array glFogfv
-!   GL_FOG_DENSITY 0.35 glFogf
-!   GL_FOG_HINT GL_DONT_CARE glHint
-!   GL_FOG_START 1.0 glFogf
-!   GL_FOG_END 5.0 glFogf
-
   GL_PROJECTION glMatrixMode
   glLoadIdentity
   viewport> first  dup  viewport> second  +
@@ -218,14 +196,14 @@ VAR: start-shape
   init-modelview-matrix-stack
   init-color-stack
 
-  initial-color >color
+  set-initial-color
 
   color> gl-set-hsba
 
   start-shape> call ;
 
 : cfdg-window* ( -- )
-[ display ] closed-quot <slate>
+  [ display ] closed-quot <slate>
   { 500 500 } over set-slate-dim
   dup "CFDG" open-window ;
 

extra/cfdg/gl/gl.factor

@@ -4,14 +4,13 @@ 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 ;
+  GL_MODELVIEW_MATRIX 16 "GLdouble" <c-array> tuck glGetDoublev ;
 
 SYMBOL: modelview-matrix-stack
 
-: init-modelview-matrix-stack ( -- )
-V{ } clone modelview-matrix-stack set ;
+: init-modelview-matrix-stack ( -- ) V{ } clone modelview-matrix-stack set ;
 
 : push-modelview-matrix ( -- )
-get-modelview-matrix modelview-matrix-stack get push ;
+  get-modelview-matrix modelview-matrix-stack get push ;
 
 : pop-modelview-matrix ( -- ) modelview-matrix-stack get pop glLoadMatrixd ;

extra/cfdg/hsv/hsv.factor

@@ -1,39 +0,0 @@
-
-USING: kernel combinators arrays sequences math combinators.lib ;
-
-IN: cfdg.hsv
-
-<PRIVATE
-
-: H ( hsv -- H ) first ;
-
-: S ( hsv -- S ) second ;
-
-: V ( hsv -- V ) third ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
-
-: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
-
-: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
-
-: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-PRIVATE>
-
-! h [0,360)
-! s [0,1]
-! v [0,1]
-
-: hsv>rgb ( hsv -- rgb )
-dup Hi
-{ { 0 [ [ V ] [ t ] [ p ] tri ] }
-  { 1 [ [ q ] [ V ] [ p ] tri ] }
-  { 2 [ [ p ] [ V ] [ t ] tri ] }
-  { 3 [ [ p ] [ q ] [ V ] tri ] }
-  { 4 [ [ t ] [ p ] [ V ] tri ] }
-  { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;

extra/cfdg/models/chiaroscuro/chiaroscuro.factor

@@ -8,17 +8,21 @@ IN: cfdg.models.chiaroscuro
 DEFER: white
 
 : black ( -- ) iterate? [
-{ { 60 [ [ 0.6 s circle ] do
-       	 [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] }
-  { 1 [ white black ] } }
-random-weighted* call
+  { { 60 [ [ 0.6 s circle ] do
+      	   [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] }
+    { 1 [ white black ] } }
+  call-random-weighted
 ] when ;
 
 : white ( -- ) iterate? [
-{ { 60 [ [ 0.6 s circle ] do
-       	 [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do ] }
-  { 1 [ black white ] } }
-random-weighted* call
+  { { 60 [
+      	   [ 0.6 s circle ] do
+      	   [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do
+         ] }
+    { 1 [
+      	  black white
+        ] } }
+  call-random-weighted
 ] when ;
 
 : chiaroscuro ( -- ) [ 0.5 b black ] do ;

extra/colors/hsv/hsv.factor

@@ -1,29 +1,41 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2007 Eduardo Cavazos
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math ;
+
+USING: kernel combinators arrays sequences math combinators.lib ;
+
 IN: colors.hsv
 
 <PRIVATE
 
-: f_ >r swap rot >r 2dup r> 6 * r> - ;
-: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
-: q ( v s f -- q ) * neg 1 + * ;
-: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
+: H ( hsv -- H ) first ;
+
+: S ( hsv -- S ) second ;
+
+: V ( hsv -- V ) third ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
+
+: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
+
+: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
+
+: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
+
+: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
 
 PRIVATE>
 
-: mod-cond ( p vector -- )
-    #! Call p mod q'th entry of the vector of quotations, where
-    #! q is the length of the vector. The value q remains on the
-    #! stack.
-    [ dupd length mod ] keep nth call ;
+! h [0,360)
+! s [0,1]
+! v [0,1]
 
-: hsv>rgb ( h s v -- r g b )
-    pick 6 * >fixnum {
-        [ f_ t_ p swap     ] ! v p t
-        [ f_ q  p -rot     ] ! q v p
-        [ f_ t_ p swapd    ] ! p v t
-        [ f_ q  p rot      ] ! p q v
-        [ f_ t_ p swap rot ] ! t p v
-        [ f_ q  p          ] ! v p q
-    } mod-cond ;
+: hsv>rgb ( hsv -- rgb )
+dup Hi
+{ { 0 [ [ V ] [ t ] [ p ] tri ] }
+  { 1 [ [ q ] [ V ] [ p ] tri ] }
+  { 2 [ [ p ] [ V ] [ t ] tri ] }
+  { 3 [ [ p ] [ q ] [ V ] tri ] }
+  { 4 [ [ t ] [ p ] [ V ] tri ] }
+  { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;

extra/random-weighted/random-weighted.factor

@@ -1,10 +1,10 @@
 
-USING: kernel quotations sequences math math.vectors random ;
+USING: kernel namespaces arrays quotations sequences assocs combinators
+       mirrors math math.vectors random combinators.lib macros bake ;
 
 IN: random-weighted
 
-: probabilities ( weights -- probabilities )
-dup sum [ / ] curry map ;
+: probabilities ( weights -- probabilities ) dup sum [ / ] curry map ;
 
 : layers ( probabilities -- layers )
 dup length 1+ [ head ] curry* map 1 tail [ sum ] map ;
@@ -13,4 +13,8 @@ dup length 1+ [ head ] curry* map 1 tail [ sum ] map ;
 probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;
 
 : random-weighted* ( seq -- elt )
-dup [ second ] map swap [ first ] map random-weighted swap nth ;
+dup [ second ] map swap [ first ] map random-weighted swap nth ;
+
+MACRO: call-random-weighted ( exp -- )
+  [ keys ] [ values <enum> >alist ] bi swap
+  [ , random-weighted , case ] bake ;