Paste: graphing but better
Author: | tubs |
Mode: | factor |
Date: | Thu, 3 Dec 2009 11:06:18 |
Plain Text |
USING:
kernel arrays inspector fry
accessors sorting sequences combinators sequences.deep
math math.constants math.order math.ranges
math.functions math.rectangles math.vectors
ui ui.gadgets ui.gadgets.editors ui.gestures ui.render
colors opengl opengl.gl
specialized-arrays.instances.float
;
IN: graphing
TUPLE: graph-gadget < gadget
x-series y-series x-range y-range auto-range
{ box rect }
;
: box-fill-color 255 0 0 0.2 <rgba> ;
: box-line-color 0 0 0 1 <rgba> ;
: line-color 255 0 0 255 <rgba> ;
: graph-gadget-down
[ box>> ] [ hand-rel ] bi >>loc drop
;
: graph-gadget-drag
[ box>> ] [ [ hand-rel ] [ box>> loc>> ] bi v- ] bi >>dim drop
;
: norm-range
[ last * ] [ first ] bi + >float
;
: hand>x
over loc>> first - over dim>> first /
swap x-range>> norm-range
;
: hand>y
over loc>> last - over dim>> last / 1 swap -
swap y-range>> norm-range
;
: box>start-x loc>> first hand>x ;
: box>end-x
[ loc>> first ] [ dim>> first ] bi + hand>x
;
: box>start-y loc>> last hand>y ;
: box>end-y
[ loc>> last ] [ dim>> last ] bi + hand>y
;
: span>range over - 2array ;
: box>x-range
dup box>> [ box>start-x ] [ box>end-x ] 2bi span>range
;
: box>y-range
dup box>> [ box>end-y ] [ box>start-y ] 2bi span>range
;
: box-positive?
box>> dim>> first 0 >
;
: reset-box
box>> { 0 0 } >>dim
;
: graph-gadget-up
dup box-positive?
[
dup box>y-range >>y-range
dup box>x-range >>x-range
f >>auto-range
]
[
t >>auto-range
] if
reset-box drop
;
: complete-gesture
relayout-1 drop f
;
M: graph-gadget handle-gesture
{
{ [ over button-down? ]
[ dup graph-gadget-down complete-gesture ] }
{ [ over button-up? ]
[ dup graph-gadget-up complete-gesture ] }
{ [ over drag? ]
[ dup graph-gadget-drag complete-gesture ] }
[ 2drop t ]
} cond
;
: gen-sin-ranges
0 2pi 0.01 <range> dup [ sin ] map
;
: find-range
natural-sort [ first ] [ last ] bi over - 2array
;
: normalize-series
swap first2 '[ _ - _ / ] map
;
: <graph-gadget>
graph-gadget new
{ 0 1 } >>x-range
{ 0 1 } >>y-range
t >>auto-range
swap >>y-series
swap >>x-series
;
: auto-range-find
dup auto-range>>
[
dup x-series>> find-range >>x-range
dup y-series>> find-range >>y-range
] when
drop
;
: draw-box?
dim>> first 0 >
;
: draw-box
box>> dup draw-box?
[
[ loc>> ] [ dim>> ] bi
[ box-fill-color gl-color gl-fill-rect ]
[ box-line-color gl-color gl-rect ] 2bi
] [ drop ] if
;
: x>screen
[ [ x-range>> ] [ x-series>> ] bi normalize-series ]
[ dim>> first ] bi
[ * ] curry map
;
: y>screen
[ [ y-range>> ] [ y-series>> ] bi normalize-series ]
[ dim>> last ] bi
'[ 1 swap - _ * ] map
;
: length-and-series
[ x-series>> length ] [ x>screen ] [ y>screen ] tri
;
: series>array
[ 2array ] { } 2map-as flatten >float-array
;
: draw-line-strip
GL_LINE_STRIP 0 rot glDrawArrays
;
: draw-series
length-and-series series>array gl-vertex-pointer
line-color gl-color
draw-line-strip
;
M: graph-gadget draw-gadget*
[ auto-range-find ] [ draw-series ] [ draw-box ] tri
;
Author: | tubs |
Mode: | factor |
Date: | Thu, 3 Dec 2009 16:03:46 |
Plain Text |
USING:
kernel arrays inspector fry
accessors sorting sequences combinators sequences.deep
math math.constants math.order math.ranges
math.functions math.rectangles math.vectors
ui ui.gadgets ui.gadgets.editors ui.gestures ui.render
colors opengl opengl.gl
specialized-arrays.instances.float
;
IN: graphing
TUPLE: graph-gadget < gadget
x-series y-series x-range y-range auto-range
{ box rect }
;
: box-fill-color 255 0 0 0.2 <rgba> ;
: box-line-color 0 0 0 1 <rgba> ;
: line-color 255 0 0 255 <rgba> ;
: graph-gadget-down
[ box>> ] [ hand-rel ] bi >>loc drop
;
: graph-gadget-drag
[ box>> ] [ [ hand-rel ] [ box>> loc>> ] bi v- ] bi >>dim drop
;
: norm-range
[ last * ] [ first ] bi + >float
;
: hand>2
[ drop - ] keep /
;
: >x-params
{
[ x-range>> ]
[ box>> loc>> first ]
[ box>> dim>> first ]
[ loc>> first ]
[ [ loc>> first ] [ dim>> first ] bi + ]
} cleave
;
: >y-params
{
[ y-range>> ]
[ [ dim>> last ] [ [ box>> dim>> last ] [ box>> loc>> last ] bi + ] bi - ]
[ box>> dim>> last ]
[ loc>> last ]
[ [ loc>> last ] [ dim>> last ] bi + ]
} cleave
;
: mangle-range
swap rot [ [ last * ] curry bi@ ] [ first + ] bi swap 2array
;
: box>range
[ hand>2 ] 2curry bi@ mangle-range
;
: box-positive?
box>> dim>> first 0 >
;
: reset-box
box>> { 0 0 } >>dim
;
: graph-gadget-up
dup box-positive?
[
f >>auto-range
dup
[ >y-params box>range >>y-range ]
[ >x-params box>range >>x-range ] bi
]
[
t >>auto-range
] if
reset-box drop
;
: complete-gesture
relayout-1 drop f
;
M: graph-gadget handle-gesture
{
{ [ over button-down? ]
[ dup graph-gadget-down complete-gesture ] }
{ [ over button-up? ]
[ dup graph-gadget-up complete-gesture ] }
{ [ over drag? ]
[ dup graph-gadget-drag complete-gesture ] }
[ 2drop t ]
} cond
;
: gen-sin-ranges
0 2pi 0.01 <range> dup [ sin ] map
;
: find-range
natural-sort [ first ] [ last ] bi over - 2array
;
: normalize-series
swap first2 '[ _ - _ / ] map
;
: <graph-gadget>
graph-gadget new
{ 0 1 } >>x-range
{ 0 1 } >>y-range
t >>auto-range
swap >>y-series
swap >>x-series
;
: auto-range-find
dup auto-range>>
[
dup x-series>> find-range >>x-range
dup y-series>> find-range >>y-range
] when
drop
;
: draw-box?
dim>> first 0 >
;
: draw-box
box>> dup draw-box?
[
[ loc>> ] [ dim>> ] bi
[ box-fill-color gl-color gl-fill-rect ]
[ box-line-color gl-color gl-rect ] 2bi
] [ drop ] if
;
: x>screen
[ [ x-range>> ] [ x-series>> ] bi normalize-series ]
[ dim>> first ] bi
[ * ] curry map
;
: y>screen
[ [ y-range>> ] [ y-series>> ] bi normalize-series ]
[ dim>> last ] bi
'[ 1 swap - _ * ] map
;
: length-and-series
[ x-series>> length ] [ x>screen ] [ y>screen ] tri
;
: series>array
[ 2array ] { } 2map-as flatten >float-array
;
: draw-line-strip
GL_LINE_STRIP 0 rot glDrawArrays
;
: draw-series
length-and-series series>array gl-vertex-pointer
line-color gl-color
draw-line-strip
;
M: graph-gadget draw-gadget*
[ auto-range-find ] [ draw-series ] [ draw-box ] tri
;
Author: | tubs |
Mode: | factor |
Date: | Fri, 4 Dec 2009 14:34:54 |
Plain Text |
USING: kernel arrays inspector fry locals
accessors sorting sequences combinators sequences.deep
math math.constants math.order math.ranges
math.functions math.rectangles math.vectors
ui ui.gadgets ui.gadgets.editors ui.gestures ui.render
colors opengl opengl.gl opengl.glu
specialized-arrays.instances.alien.c-types.float ;
IN: graphing
TUPLE: graph-gadget < gadget
x-series y-series x-range y-range auto-range
{ box rect }
;
: box-fill-color 255 0 0 0.2 <rgba> ;
: box-line-color 0 0 0 1 <rgba> ;
: line-color 255 0 0 255 <rgba> ;
: axis-color 0 0 0 255 <rgba> ;
: graph-gadget-down
[ box>> ] [ hand-rel ] bi >>loc drop
;
: graph-gadget-drag
[ box>> ] [ [ hand-rel ] [ box>> loc>> ] bi v- ] bi >>dim drop
;
: norm-range
[ last * ] [ first ] bi + >float
;
: hand>2
[ drop - ] keep /
;
: >x-params
{
[ x-range>> ]
[ box>> loc>> first ]
[ box>> dim>> first ]
[ loc>> first ]
[ [ loc>> first ] [ dim>> first ] bi + ]
} cleave
;
: >y-params
{
[ y-range>> ]
[ [ dim>> last ] [ [ box>> dim>> last ] [ box>> loc>> last ] bi + ] bi - ]
[ box>> dim>> last ]
[ loc>> last ]
[ [ loc>> last ] [ dim>> last ] bi + ]
} cleave
;
: mangle-range
swap rot [ [ last * ] curry bi@ ] [ first + ] bi swap 2array
;
: box>range
[ hand>2 ] 2curry bi@ mangle-range
;
: box-positive?
box>> dim>> first 0 >
;
: reset-box
box>> { 0 0 } >>dim
;
: graph-gadget-up
dup box-positive?
[
f >>auto-range
dup
[ >y-params box>range >>y-range ]
[ >x-params box>range >>x-range ] bi
]
[
t >>auto-range
] if
reset-box drop
;
: complete-gesture
relayout-1 drop f
;
M: graph-gadget handle-gesture
{
{ [ over button-down? ]
[ dup graph-gadget-down complete-gesture ] }
{ [ over button-up? ]
[ dup graph-gadget-up complete-gesture ] }
{ [ over drag? ]
[ dup graph-gadget-drag complete-gesture ] }
[ 2drop t ]
} cond
;
: gen-sin-ranges
0 2pi 0.01 <range> dup [ sin ] map
;
: find-range
natural-sort [ first ] [ last ] bi over - 2array
;
: normalize-series
swap first2 '[ _ - _ / ] map
;
: <graph-gadget>
graph-gadget new
{ 0 1 } >>x-range
{ 0 1 } >>y-range
t >>auto-range
swap >>y-series
swap >>x-series
;
: auto-range-find
dup auto-range>>
[
dup x-series>> find-range >>x-range
dup y-series>> find-range >>y-range
] when
drop
;
: draw-box?
dim>> first 0 >
;
: draw-box
box>> dup draw-box?
[
[ loc>> ] [ dim>> ] bi
[ box-fill-color gl-color gl-fill-rect ]
[ box-line-color gl-color gl-rect ] 2bi
] [ drop ] if
;
: length-and-series
[ x-series>> length ] [ x-series>> ] [ y-series>> ] tri
;
: series>array
[ 2array ] { } 2map-as flatten >float-array
;
: range>span
first2 over +
;
: draw-line-strip
GL_LINE_STRIP 0 rot glDrawArrays
;
: draw-x-axis
swap GL_LINES glBegin
0.0 swap glVertex2f
0.0 swap glVertex2f
glEnd
;
: draw-y-axis
swap GL_LINES glBegin
0.0 glVertex2f
0.0 glVertex2f
glEnd
;
: draw-axes
[ x-range>> ] [ y-range>> ] bi [ range>span ] bi@
draw-x-axis draw-y-axis
;
: draw-series
length-and-series series>array gl-vertex-pointer
line-color gl-color draw-line-strip axis-color gl-color
;
: enable-2d
GL_PROJECTION glMatrixMode
glPushMatrix
glLoadIdentity
-1 1 glOrtho
GL_MODELVIEW glMatrixMode
glPushMatrix
glLoadIdentity
GL_DEPTH_TEST glDisable
;
: disable-2d
GL_PROJECTION glMatrixMode
glPopMatrix
GL_MODELVIEW glMatrixMode
glPopMatrix
;
: do-2d
enable-2d call disable-2d
;
M: graph-gadget draw-gadget*
[ auto-range-find ] keep
dup [ x-range>> ] [ y-range>> ] bi [ range>span ] bi@
GL_LINE_SMOOTH glEnable
enable-2d dup [ draw-series ] [ draw-axes ] bi disable-2d draw-box
;
New Annotation