Paste: graphing but better

Author:	tubs
Mode:	factor
Date:	Thu, 3 Dec 2009 11:06:18

Plain Text |

Delete Paste

! Copyright (C) 2009 Michael Worcester
! See http://factorcode.org/license.txt for BSD license.
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

! test

! NOTE: range is { min size }, NOT { min max }

TUPLE: graph-gadget < gadget 
 x-series y-series x-range y-range auto-range
 { box rect }
;

: box-fill-color ( -- color ) 255 0 0 0.2 <rgba> ;
: box-line-color ( -- color ) 0 0 0 1 <rgba> ;
: line-color ( -- color ) 255 0 0 255 <rgba> ;

: graph-gadget-down ( gadget -- )
 [ box>> ] [ hand-rel ] bi >>loc drop
;

: graph-gadget-drag ( gadget -- )
 [ box>> ] [ [ hand-rel ] [ box>> loc>> ] bi v- ] bi >>dim drop
;

: norm-range ( val range -- norm )
 [ last * ] [ first ] bi + >float
;

! BAD: replicate of hand>y
: hand>x ( gadget hand-x -- x )
 over loc>> first - over dim>> first /
 swap x-range>> norm-range
;

! BAD: replicate of hand>x
: hand>y ( gadget hand-y -- y )
 over loc>> last - over dim>> last / 1 swap -
 swap y-range>> norm-range
;

! BAD: replicate of box>start-y
: box>start-x ( gadget box -- start-x ) loc>> first hand>x ;

! BAD: replicate of box>end-y
: box>end-x ( gadget box -- end-x )
 [ loc>> first ] [ dim>> first ] bi + hand>x
;

! BAD: replicate of box>start-x
: box>start-y ( gadget box -- start-y ) loc>> last hand>y ;

! BAD: replicate of box>end-x
: box>end-y ( gadget box -- end-y )
 [ loc>> last ] [ dim>> last ] bi + hand>y
;

: span>range ( start end -- range ) over - 2array ;

! BAD: replicate of box>y-range ( but reversed )
: box>x-range ( gadget -- x-range )
 dup box>> [ box>start-x ] [ box>end-x ] 2bi span>range
;

! BAD: replicate of box>xy-range ( but reversed )
: box>y-range ( gadget -- y-range )
 dup box>> [ box>end-y ] [ box>start-y ] 2bi span>range
;

: box-positive? ( gadget -- ? )
 box>> dim>> first 0 >
;

: reset-box ( gadget -- box )
 box>> { 0 0 } >>dim
;

: graph-gadget-up ( gadget -- )
 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 ( gesture gadget -- ? )
 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 ( -- xx yy )
 0 2pi 0.01 <range> dup [ sin ] map
;

: find-range ( sequence -- range )
 natural-sort [ first ] [ last ] bi over - 2array
;

: normalize-series ( range series -- normalized-series )
 swap first2 '[ _ - _ / ] map
;

: <graph-gadget> ( xx yy -- 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 ( gadget -- )
 dup auto-range>>
  [
    dup x-series>> find-range >>x-range
    dup y-series>> find-range >>y-range
  ] when
 drop
;

: draw-box? ( box -- ? )
 dim>> first 0 >
;

: draw-box ( gadget -- )
 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 ( gadget -- x-screen )
 [ [ x-range>> ] [ x-series>> ] bi normalize-series ]
 [ dim>> first ] bi
 [ * ] curry map
;

: y>screen ( gadget -- y-screen )
 [ [ y-range>> ] [ y-series>> ] bi normalize-series ]
 [ dim>> last ] bi
 '[ 1 swap - _ * ] map
;

: length-and-series ( gadget -- length x-screen y-screen )
 [ x-series>> length ] [ x>screen ] [ y>screen ] tri
;

: series>array ( x-screen y-screen -- xy-screen-array )
 [ 2array ] { } 2map-as flatten >float-array
;

: draw-line-strip ( length -- )
 GL_LINE_STRIP 0 rot glDrawArrays
;

: draw-series ( gadget -- )
 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
;

Annotation: almost all the x/y stuff gone

Author:	tubs
Mode:	factor
Date:	Thu, 3 Dec 2009 16:03:46

Plain Text |

Delete Annotation

! Copyright (C) 2009 Michael Worcester
! See http://factorcode.org/license.txt for BSD license.
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

! test

! NOTE: range is { min size }, NOT { min max }

TUPLE: graph-gadget < gadget 
 x-series y-series x-range y-range auto-range
 { box rect }
;

: box-fill-color ( -- color ) 255 0 0 0.2 <rgba> ;
: box-line-color ( -- color ) 0 0 0 1 <rgba> ;
: line-color ( -- color ) 255 0 0 255 <rgba> ;

: graph-gadget-down ( gadget -- )
 [ box>> ] [ hand-rel ] bi >>loc drop
;

: graph-gadget-drag ( gadget -- )
 [ box>> ] [ [ hand-rel ] [ box>> loc>> ] bi v- ] bi >>dim drop
;

: norm-range ( val range -- norm )
 [ last * ] [ first ] bi + >float
;

: hand>2 ( i loc dim -- val )
 [ drop - ] keep /
;

: >x-params ( gadget -- start end range x w )
 {
     [ x-range>> ]
     [ box>> loc>> first ]
     [ box>> dim>> first ]
     [ loc>> first ]
     [ [ loc>> first ] [ dim>> first ] bi + ]
 } cleave
;

! Alas, stupid y being upside down (plot versus pixels) means
! we have this... monstrosity (even if it is quite cleave'r).
: >y-params ( gadget -- start end range y h )
 {
     [ y-range>> ]
     [ [ dim>> last ] [ [ box>> dim>> last ] [ box>> loc>> last ] bi + ] bi - ]
     [ box>> dim>> last ]
     [ loc>> last ]
     [ [ loc>> last ] [ dim>> last ] bi + ]
 } cleave
;

! BAD: still uses a rot here...
: mangle-range ( range a b -- range )
 swap rot [ [ last * ] curry bi@ ] [ first + ] bi swap 2array
;

: box>range ( start end range y h  -- range )
 [ hand>2 ] 2curry bi@ mangle-range
;

: box-positive? ( gadget -- ? )
 box>> dim>> first 0 >
;

: reset-box ( gadget -- box )
 box>> { 0 0 } >>dim
;

: graph-gadget-up ( gadget -- )
 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 ( gesture gadget -- ? )
 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 ( -- xx yy )
 0 2pi 0.01 <range> dup [ sin ] map
;

: find-range ( sequence -- range )
 natural-sort [ first ] [ last ] bi over - 2array
;

: normalize-series ( range series -- normalized-series )
 swap first2 '[ _ - _ / ] map
;

: <graph-gadget> ( xx yy -- 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 ( gadget -- )
 dup auto-range>>
  [
    dup x-series>> find-range >>x-range
    dup y-series>> find-range >>y-range
  ] when
 drop
;

: draw-box? ( box -- ? )
 dim>> first 0 >
;

: draw-box ( gadget -- )
 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 ( gadget -- x-screen )
 [ [ x-range>> ] [ x-series>> ] bi normalize-series ]
 [ dim>> first ] bi
 [ * ] curry map
;

: y>screen ( gadget -- y-screen )
 [ [ y-range>> ] [ y-series>> ] bi normalize-series ]
 [ dim>> last ] bi
 '[ 1 swap - _ * ] map
;

: length-and-series ( gadget -- length x-screen y-screen )
 [ x-series>> length ] [ x>screen ] [ y>screen ] tri
;

: series>array ( x-screen y-screen -- xy-screen-array )
 [ 2array ] { } 2map-as flatten >float-array
;

: draw-line-strip ( length -- )
 GL_LINE_STRIP 0 rot glDrawArrays
;

: draw-series ( gadget -- )
 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
;

Annotation: Uses open gl for transforms now

Author:	tubs
Mode:	factor
Date:	Fri, 4 Dec 2009 14:34:54

Plain Text |

Delete Annotation

! Copyright (C) 2009 Michael Worcester
! See http://factorcode.org/license.txt for BSD license.
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 ;
! specialized-arrays.instances.float ;

IN: graphing

! test

! NOTE: range is { min size }, NOT { min max }

TUPLE: graph-gadget < gadget 
 x-series y-series x-range y-range auto-range
 { box rect }
;

: box-fill-color ( -- color ) 255 0 0 0.2 <rgba> ;
: box-line-color ( -- color ) 0 0 0 1 <rgba> ;
: line-color ( -- color ) 255 0 0 255 <rgba> ;
: axis-color ( -- color ) 0 0 0 255 <rgba> ;

: graph-gadget-down ( gadget -- )
 [ box>> ] [ hand-rel ] bi >>loc drop
;

: graph-gadget-drag ( gadget -- )
 [ box>> ] [ [ hand-rel ] [ box>> loc>> ] bi v- ] bi >>dim drop
;

: norm-range ( val range -- norm )
 [ last * ] [ first ] bi + >float
;

: hand>2 ( i loc dim -- val )
 [ drop - ] keep /
;

: >x-params ( gadget -- start end range x w )
 {
     [ x-range>> ]
     [ box>> loc>> first ]
     [ box>> dim>> first ]
     [ loc>> first ]
     [ [ loc>> first ] [ dim>> first ] bi + ]
 } cleave
;

! Alas, stupid y being upside down (plot versus pixels) means
! we have this... monstrosity (even if it is quite cleave'r).
: >y-params ( gadget -- start end range y h )
 {
     [ y-range>> ]
     ! this does graph.height - (box.y + box.height)
     [ [ dim>> last ] [ [ box>> dim>> last ] [ box>> loc>> last ] bi + ] bi - ]
     [ box>> dim>> last ]
     [ loc>> last ]
     [ [ loc>> last ] [ dim>> last ] bi + ]
 } cleave
;

! BAD: still uses a rot here...
: mangle-range ( range a b -- range )
 swap rot [ [ last * ] curry bi@ ] [ first + ] bi swap 2array
;

: box>range ( start end range y h  -- range )
 [ hand>2 ] 2curry bi@ mangle-range
;

: box-positive? ( gadget -- ? )
 box>> dim>> first 0 >
;

: reset-box ( gadget -- box )
 box>> { 0 0 } >>dim
;

: graph-gadget-up ( gadget -- )
 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 ( gesture gadget -- ? )
 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 ( -- xx yy )
 0 2pi 0.01 <range> dup [ sin ] map
;

: find-range ( sequence -- range )
 natural-sort [ first ] [ last ] bi over - 2array
;

: normalize-series ( range series -- normalized-series )
 swap first2 '[ _ - _ / ] map
;

: <graph-gadget> ( xx yy -- 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 ( gadget -- )
 dup auto-range>>
  [
    dup x-series>> find-range >>x-range
    dup y-series>> find-range >>y-range
  ] when
 drop
;

: draw-box? ( box -- ? )
 dim>> first 0 >
;

: draw-box ( gadget -- )
 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 ( gadget -- length x-screen y-screen )
 [ x-series>> length ] [ x-series>> ] [ y-series>> ] tri
;

: series>array ( x-screen y-screen -- xy-screen-array )
 [ 2array ] { } 2map-as flatten >float-array
;

: range>span ( range -- start end )
 first2 over +
;

: draw-line-strip ( length -- )
 GL_LINE_STRIP 0 rot glDrawArrays
;

: draw-x-axis ( start end -- )
 swap GL_LINES glBegin
 0.0 swap glVertex2f 
 0.0 swap glVertex2f
 glEnd
;

: draw-y-axis ( start end -- )
 swap GL_LINES glBegin
 0.0 glVertex2f
 0.0 glVertex2f
 glEnd
;

: draw-axes ( gadget -- )
 [ x-range>> ] [ y-range>> ] bi [ range>span ] bi@
 draw-x-axis draw-y-axis
;

: draw-series ( gadget -- )
 length-and-series series>array gl-vertex-pointer
 line-color gl-color draw-line-strip axis-color gl-color
;

: enable-2d ( x w y h -- )
  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 ( quot x w y h -- )
  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

Summary:
Author:
Mode:	PostgreSQLPowerCenter Parameter Fileactionscriptadaada95ans-forth94antantlrantlr4apacheconfapdlapplescriptaspaspect-jassembly-agcassembly-agsassembly-arm32assembly-m68kassembly-macro32assembly-mcs51assembly-parrotassembly-r2000assembly-x86avroawkbbatchbbjbcelbeanshellbibtexbinsource-agccc#c++cfscriptchillcilclipsclojurecmakecobolcoffeescriptcoldfusioncplex-lpcsscsvcvs-commitddartdjangodockerfiledotdoxygendrawj2ddsssleiffelembperlerlangfactorfhtmlforthfortranfortran90foxprofreemarkergcbasicgettextgherkingnuplotgogradlegroovygsphaskellhaxehexhl7v2hlslhtaccesshtmlhxmli4glicalendariconidlinforminiinno-setupinterlisiojamonjavajava module-infojavaccjavafxjavascriptjcljedit-actionsjflexjhtmljmkjsonjspkotlinlatexlexlilypondlispliterate-haskelllogslogtalklotosluam4macroschedulermailmakefilemaplemarkdownmavenmavscriptmetapostmlmodula3moinmqscmustache-templatemxmlmyghtymysqln3netrexxnqcnsis2objective-cobjectrexxoccamomnimarkopensipsoutlinepascalpatchperlphppikepl-sqlpl-sql9pl1plaintexplantumlpop11postscriptpovraypowerdynamopowershellprogressprologpropertiesprotobufpspptlpurepvwavepyrexpythonrakefilercprdrebolredcoderelax-ng-compactrenderman-ribrestrfcrhtmlroffrpm-specrtfrubyrustrviews#s+sassbtscalaschemesdl/prsgmlshellscriptshtmlsipsippslateslaxsmalltalksmartysmi-mibsql-loadersqrsquidconfstatasvn-commitswiftswigtcltemplate-toolkittextexinfotexttldtransact-sqltsptwikityposcripturluscriptvalavbscriptvelocityverilogvhdlvisualbasicvrml2wellknowntextxmlxqxslyabyamlzpt
Body:

Done