( -*-forth-*- )

( some pd symbols )
<s> anything constant s_anything
<s> signal   constant s_signal
<s> float    constant s_float
<s> symbol   constant s_symbol
<s> list     constant s_list

( -- outlet test )
: outlet        s_anything new-outlet constant ;

( -- )
: signal-outlet s_signal new-outlet drop ;
: inlet         <s> <s> new-inlet ;
: signal-inlet  s_signal s_signal new-inlet ;


( pd arrays )

fields
: array.buffer field ; ( start of visible array )
: array.index  field ; ( current point index )
: array.size   field ; ( current visible size  )
: array.name   field ; ( pd array name )
: array.redraw array.name @ redraw-array ;

: array.update >r
    r array.name @ get-array
    r array.buffer !
    r array.size !
    0 r> array.index ! ;
: array.clear >r
    r array.update
    r array.buffer
    r> array.size @ for 0 over point.write next ;


: array ( name -- )
    create here >r 4 cells allot
    r  array.name !
    r>  array.update ;

( pd clock stuff )
variable tick-interval ( tick interval )
floats 1000. tick-interval ! ints

: tick ;                     ( default tick routine )
: tick-restart 0 timer! ;    ( restart the ticker )


: perform ; ( default dummy tilde perform routine )



( pd messages )

( atom compilation )
: _ comma ;  ( shortcut. we can't use the real comma because its a pd separator )
: 2_ _ _ ;

: pointer_   A_POINTER 2_ ; ( ptr -- )
: symbol_    A_SYMBOL 2_ ;  ( symbol -- )
: float_     A_FLOAT 2_ ;   ( float -- )
: null_      0 0 2_ ;       ( -- )


( compiler for several body types )




( tag -- )
: msg-tagfloat0_ symbol_ float_ null_ ;

( -- )
: msg-float0_   [s] float msg-tagfloat0_ ;
: msg-bang_     [s] bang symbol_ null_ ;




( float msg -- )
( msg format : [ RECEIVER | SELECTOR | FLOAT ] )
: send-float >r
    r [ 5 cells add ]L add !
    r> send ;


( defining words for message senders )

: def-float>o    ( outlet/object  -- )    create pointer_ msg-float0_    does> ( float -- ) send-float ;
: def-tagfloat>o ( tag outlet/object -- ) create pointer_ msg-tagfloat0_ does> ( float -- ) send-float ;
: def-bang>o     ( outlet/object -- )     create pointer_ msg-bang_      does> ( -- )  send ;

: def-float>s    ( symbol -- )            create symbol_ msg-float0_     does> ( float -- ) send-float ;
: def-tagfloat>s ( tag symbol -- )        create symbol_ msg-tagfloat0_  does> ( float -- ) send-float ;
: def-bang>s     ( symbol -- )            create symbol_ msg-bang_       does> ( -- ) send ;
    


( some parsing words for interprete mode message sending )
( todo: factor these into non-parsing core words and parsing shell words )

( parse the rest of input _ until semi _ verbatim )
( and compile a message )

( read rest of input stream into allot buffer )

: <>_ 
    begin
	accept            ( read from input )
	dup 0 = >r        ( loop code )
	2_                ( compile atom )
    r> until
;

: <atom-comma> accept comma comma ;


( parse and route message to receiver )
( todo: make this understand floats too for outlets )
( -- )
: <>-route here>r <>_ r send r>here ;


( parse and send message to object/outlet )
( object -- )
: <>-obj    here>r pointer_ <>_ r send r>here ;

( create a new pd object )
( -- object )
: <>-pd-new here>r factory pointer_ <>_ r send r>here newest ;


( float output methods )
( f outlet -- )
: float-out  here>r pointer_ float_ null_ r send r>here ;