Paste: graphing but better

! 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
;