/*
 *   Pure Data Packet - Basic forth words operation on data stack.
 *   Copyright (c) by Tom Schouten <tom@zwizwa.be>
 *
 *   This program is free software; you can redistribute it and/or modify
 *   it under the terms of the GNU General Public License as published by
 *   the Free Software Foundation; either version 2 of the License, or
 *   (at your option) any later version.
 *
 *   This program is distributed in the hope that it will be useful,
 *   but WITHOUT ANY WARRANTY; without even the implied warranty of
 *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *   GNU General Public License for more details.
 *
 *   You should have received a copy of the GNU General Public License
 *   along with this program; if not, write to the Free Software
 *   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 */

#include <stdlib.h>
#include <stdio.h>
#include <math.h>
#include <stdarg.h>
#include <string.h>
#include <pf/packet.h>
#include <pf/type.h>
#include <pf/forth.h>
#include <pf/string.h>
#include <pf/stream.h>
#include <pf/mem.h>
#include <pf/debug.h>
#include <pf/config.h>
#include <pf/hash.h>
#include <pf/plugin.h>
#include <pf/macros.h>



#define D if (0)


/* some stack manips */
/* DUP / DROP: not defined for list / tree */
pf_error_t pf_stack_dup(pf_list_t *l){
    if (!l->first) return e_underflow;
    pf_stack_push_atom(l, l->first);
    EXIT;
}

PF_PRIMITIVE(pf_stack_over)
{
    CHECKN(2);
    pf_stack_push_atom(s, ARG1);
    EXIT;
}


// different prototype: legacy thingy
pf_error_t pf_stack_drop(pf_stack_t *s)
{
    CHECKN(1);
    pf_stackatom_drop(pf_list_pop_atom(s));
    EXIT;
}

pf_error_t pf_stack_swap(pf_stack_t *s)
{
    pf_word_t w;
    pf_word_type_t t;
    CHECKN(2);
    w = ARG0->w;
    t = ARG0->t;
    ARG0->w = ARG1->w;
    ARG0->t = ARG1->t;
    ARG1->w = w;
    ARG1->t = t;
    EXIT;
    
}


/* type specific pops: give a least surprize answer */
pf_error_t pf_stack_pop_float(pf_stack_t *s, float *f)
{
    CHECKN(1);
    if (ARG0->t == a_float) *f = ARG0->w.w_float; 
    else if (ARG0->t == a_int) *f = (float)ARG0->w.w_int; 
    else *f = 0.0f;
    DROP1;
    EXIT;
}

pf_error_t pf_stack_pop_int(pf_stack_t *s, int *i)
{
    CHECKN(1);
    if (ARG0->t == a_float) *i = (int)ARG0->w.w_float; 
    else *i = ARG0->w.w_int; 
    DROP1;
    EXIT;
}

pf_error_t pf_stack_pop_pointer(pf_stack_t *s, void **x)
{
    CHECKN(1);
    *x = (ARG0->t == a_pointer) ? ARG0->w.w_pointer : 0; 
    DROP1;
    EXIT;
}

pf_error_t pf_stack_pop_atom_pointer(pf_stack_t *s, pf_atom_t **a)
{
    CHECKN(1);
    *a = (ARG0->t == a_atom_pointer) ? ARG0->w.w_atom_pointer : 0; 
    DROP1;
    EXIT;
}

pf_error_t pf_stack_pop_symbol(pf_stack_t *s, pf_symbol_t **x)
{
    CHECKN(1);
    *x = (ARG0->t == a_symbol) ? ARG0->w.w_symbol : pf_symbol("invalid"); 
    DROP1;
    EXIT;
}

pf_error_t pf_stack_pop_list(pf_stack_t *s, pf_list_t **x)
{
    CHECKN(1);
    if (ARG0->t == a_list){
	*x = ARG0->w.w_list;
	ARG0->t = a_undef; // remove ref
    }
    else {
	*x = 0;
    }
    DROP1;
    EXIT;
}
/* packets popped from the stack are owned by the caller:
   ownership is transferred. */

pf_error_t pf_stack_pop_packet(pf_stack_t *s, pf_packet_t *p)
{
    CHECKN(1);
    if (ARG0->t == a_packet){
	*p = ARG0->w.w_packet;
	ARG0->t = a_undef; // remove ref
    }
    else {
	*p = 0;
    }
    DROP1;
    EXIT;
}


/* indexed acces to stack */
PF_PRIMITIVE(pf_stack_pick)
{
  pf_atom_t *a;
  int index;
  pf_error_t e;
  if (e = pf_stack_pop_int(s, &index)) return e;
  if (index >= s->elements) return e_underflow;
  for (a=ARG0; index--; a=a->next);
  pf_stack_push_atom(s, a);
  EXIT;
}

/* pack words from stack into a list */
PF_PRIMITIVE(pf_stack_pack)
{
    int n;
    pf_list_t *l;
    pf_atom_t *a;
    CHECK1(a_int);
    n = ARG0->w.w_int;
    if (s->elements < n+1) return e_underflow;
    DROP1;
    l = pf_list_new();
    if (n) {

	/* find last atom */
	s->elements -= n;
	l->elements += n;
	for (a=ARG0; --n; a=a->next);

	/* move chain */
	if (s->last == a) s->last = 0;
	l->first = ARG0;
	l->last = a;
	// ARG0 = a->next;
	// FIXME: list lvalues
	s->first = a->next;

	a->next = 0;
    }

    PUSH_LIST(l);
    EXIT;
    
}

PF_PRIMITIVE(pf_stack_unpack)
{
    pf_list_t *l;
    CHECKN(1);
    if (!pf_atom_islist(ARG0)) return e_type;
    l = pf_list_pop(s).w_list;

    if (l->elements){
	pf_list_join(l, s);
	vm->data_stack = l;
    }
    EXIT;
}

static pf_error_t getlistptr_size(pf_stack_t *s, pf_list_t **l, int elements){
    CHECK1(a_atom_pointer);
    pf_atom_t *a = ARG0->w.w_atom_pointer;
    if (!a) return e_pointer;
    if (!(pf_atom_islist(a))) return e_type;
    *l = a->w.w_list;
    if (!(*l)) return e_internal;
    if ((*l)->elements < elements) return e_underflow;
    DROP1;
    EXIT;
}

static pf_error_t getlistptr(pf_stack_t *s, pf_list_t **l){
    return getlistptr_size(s, l, 0);
}

// indirect list ops: for implementing queues and stacks
// ( el plist -- )
PF_PRIMITIVE(pf_stack_plist_push){
    pf_error_t e;
    pf_list_t *l;
    if (e = getlistptr(s, &l)) return e;
    CHECKN(1);
    pf_list_push_atom(l, pf_list_pop_atom(s));
    EXIT;
}


PF_PRIMITIVE(pf_stack_plist_queue){
    pf_error_t e;
    pf_list_t *l;
    if (e = getlistptr(s, &l)) return e;
    CHECKN(1);
    pf_list_queue_atom(l, pf_list_pop_atom(s));
    EXIT;
}
PF_PRIMITIVE(pf_stack_plist_pop){
    pf_error_t e;
    pf_list_t *l;
    if (e = getlistptr_size(s, &l, 1)) return e;
    pf_list_push_atom(s, pf_list_pop_atom(l));
    EXIT;
}
PF_PRIMITIVE(pf_stack_plist_head){
    pf_error_t e;
    pf_list_t *l;
    if (e = getlistptr(s, &l)) return e;
    pf_list_push_atom_pointer(s, l->first);
    EXIT;
}
PF_PRIMITIVE(pf_stack_plist_tail){
    pf_error_t e;
    pf_list_t *l;
    if (e = getlistptr(s, &l)) return e;
    pf_list_push_atom_pointer(s, l->last);
    EXIT;
}

// (el n plist -- )
PF_PRIMITIVE(pf_stack_plist_insert){
    pf_error_t e;
    pf_list_t *l;
    if (e = getlistptr(s, &l)) return e;
    CHECKN(2);
    CHECK1(a_int);
    int n = ARG0->w.w_int;
    if ((n < 0) || (n > l->elements)) return e_inval;
    DROP1;
    pf_list_insert_atom(l, n, pf_list_pop_atom(s));
    EXIT;
}


// truncate a stack
// can be used for ds too
PF_PRIMITIVE(pf_stack_plist_trunc){
    CHECK2(a_atom_pointer, a_int);
    pf_error_t e;
    pf_list_t *l;
    if (e = getlistptr(s, &l)) return e;
    int n = pf_list_pop(s).w_int;

    while (n < l->elements) pf_stack_drop(l);
    while (n > l->elements) pf_list_push(l, a_undef, (pf_word_t)0);
    EXIT;
}


static int atom_equal(pf_atom_t *a, pf_atom_t *b){
    return ((a->t == b->t) && (a->w.w_int == b->w.w_int));
}

PF_PRIMITIVE(pf_stack_plist_contains){
    pf_error_t e;
    pf_list_t *l;
    int result = 0;
    if (e = getlistptr(s, &l)) return e;
    pf_atom_t *thing = pf_list_pop_atom(s); // get thing to search
    pf_atom_t *a = l->first;
    while (a){
	if (atom_equal(thing, a)) { result = -1; goto done; }
	a = a->next;
    }

  done:
    pf_stackatom_drop(thing);
    PUSH_INT(result);
    EXIT;
    
}

PF_PRIMITIVE(pf_stack_plist_remove){
    pf_error_t e;
    pf_list_t *l;
    if (e = getlistptr(s, &l)) return e;
    if (!(l->elements)) return e_underflow;
    pf_atom_t *thing = pf_list_pop_atom(s); // get thing to remove
    pf_atom_t *a = l->first;

    // first element?
    if (atom_equal(a, thing)){
	pf_stack_drop(l); 
	e = e_ok; 
	goto done;

    }

    // other element
    else{
	while (a->next){
	    if (atom_equal(a->next, thing)){
		pf_atom_t *removed = a->next;
		a->next = removed->next;
		l->elements--;
		if (l->last == removed) l->last = a;
		pf_stackatom_drop(removed);
		e = e_ok;
		goto done;
	    }
	    a = a->next;
	}
    }

    // not found
    e = e_inval;
  done:
    pf_stackatom_drop(thing);
    return e;
}


PF_PRIMITIVE(pf_stack_plist_atfind){ // lookup something in a list
    CHECK2(a_atom_pointer, a_symbol);
    if (ARG0->w.w_atom_pointer->t != a_list) return e_type;
    pf_list_t *l = ARG0->w.w_atom_pointer->w.w_list;
    pf_atom_t *a = l->first;
    while (a){
	if (a->t != a_list) return e_type;
	pf_atom_t *first = a->w.w_list->first;
	if (first->t != a_symbol) return e_type;
	if (ARG1->w.w_symbol == first->w.w_symbol){
	    DROP1;
	    DROP1;
	    pf_list_push_atom_pointer(s, first->next);
	    EXIT;
	}
	a = a->next;
    }
    return e_undef;
}


PF_PRIMITIVE(pf_stack_plist_resize){ // i.e. for delay lines ( size plist -- )
    pf_error_t e;
    pf_list_t *l;
    if (e = getlistptr(s, &l)) return e;
    CHECK1(a_int);
    int size = pf_list_pop(s).w_int;
    if (size < 0) size = 0;

    if (l->elements == 0) pf_list_push(l, a_undef, (pf_word_t)0);

    while (size < l->elements) {pf_stack_drop(l);}
    while (size > l->elements) {pf_stack_dup(l);}
    EXIT;
}


// direct list ops (list on data stack)

// ( list el -- newlist )
PF_PRIMITIVE(pf_stack_list_push)
{
    pf_list_t *l;
    CHECKN(2);
    if (!(pf_atom_islist(ARG1))) return e_type;
    l = ARG1->w.w_list;
    pf_list_push_atom(l, pf_list_pop_atom(s));
    EXIT;
    
}

PF_PRIMITIVE(pf_stack_list_queue)
{
    pf_list_t *l;
    CHECKN(2);
    if (!(pf_atom_islist(ARG1))) return e_type;
    l = ARG1->w.w_list;
    pf_list_queue_atom(l, pf_list_pop_atom(s));
    EXIT;
    
}

PF_PRIMITIVE(pf_stack_list_pop)
{
    pf_list_t *l;
    CHECKN(1);
    if (!(pf_atom_islist(ARG0))) return e_type;
    l = ARG0->w.w_list;
    if (!l->first) return e_underflow;
    pf_list_push_atom(s, pf_list_pop_atom(l));
    EXIT;
}




PF_PRIMITIVE(pf_stack_list_join)
{
    pf_atom_t *a;
    pf_list_t *l;
    CHECKN(2);
    int list_right = pf_atom_islist(ARG0);
    int list_left = pf_atom_islist(ARG1);

    int flag = ((list_left & 1) << 1) | (list_right & 1);
    switch(flag){

    case 0: // (nolist nolist)
	return e_type;

    case 1: // (nolist list)
	l = pf_list_pop(s).w_list;
	pf_list_push_atom(l, pf_list_pop_atom(s));
	PUSH_LIST(l);
	EXIT;

    case 2: // (list nolist)
	a = pf_list_pop_atom(s);
	pf_list_queue_atom(ARG0->w.w_list, a);
	EXIT;

    case 3: // (list list)
	l = pf_list_pop(s).w_list;
	pf_list_join(ARG0->w.w_list, l);
	EXIT;
    }

    EXIT;
}


PF_PRIMITIVE(pf_stack_list_size)
{
    CHECKN(1);
    pf_atom_t *a = ARG0;
    // if (a->t == a_atom_pointer) a = a->w.w_atom_pointer; // deref
    if (!(pf_atom_islist(a))) return e_type;
    pf_list_push(s, a_int, (pf_word_t)a->w.w_list->elements);
    EXIT;
}



// transpose a list of lists
PF_PRIMITIVE(pf_stack_list_transpose)
{
    int n;
    CHECK1(a_list);
    pf_list_t *container = ARG0->w.w_list;

    PF_STACK_CHECK1(container, a_list);
    n = container->first->w.w_list->elements;

    /* check input container structure */
    pf_atom_t *a = container->first;
    for (a=container->first;a;a=a->next){
	if (a->t != a_list) return e_type;
	if (a->w.w_list->elements != n) return e_inval;
    }

    /* create output container */
    pf_list_t *out_container = pf_list_new();
    while (n--){
	pf_list_t *l = pf_list_new();
	for (a=container->first;a;a=a->next){
	    pf_list_queue_atom(l, pf_list_pop_atom(a->w.w_list));
	}
	pf_list_queue_list(out_container, l);
    }

    /* cleanup */
    pf_tree_free(container);
    ARG0->w.w_list = out_container;

    EXIT;

}


static inline void swapatom(pf_atom_t *a, pf_atom_t *b)
{
    pf_word_type_t t;
    int i;
    t = a->t;
    i = a->w.w_int;
    a->t = b->t;
    a->w.w_int = b->w.w_int;
    b->t = t;
    b->w.w_int = i;
}


/*
  faculty base encoding:
  digit 2! -> last pick
  digit 3! -> second last
  ...
*/

void get_permutation(int *perm, int coefs, int number)
{
    int base = 2;
    while(coefs--){
	*perm++ = number % base;
	number /= base;
	base++;
    }
}


/* permute using faculty base encoded permutations */
PF_PRIMITIVE(pf_stack_list_permute)
{
    CHECK2(a_int, a_list);
    int number = pf_list_pop(s).w_int;
    if (number < 0) number = 0;
    pf_list_t *l = ARG0->w.w_list;
    int coefs = l->elements - 1;

    if (coefs < 0) EXIT;
    int perm[coefs];


    get_permutation(perm, coefs, number);

    int i = coefs-1;
    pf_atom_t *a = l->first;
    while (i >= 0){
	pf_atom_t *b = a;
	int n = perm[i];
	//pf_post("n = %d", n);
	while (n--){
	    PF_ASSERT(b);
	    b = b->next;
	}
	PF_ASSERT(b);
	swapatom(a, b);
	a = a->next;
	i--;
    }

    EXIT;
}




PF_PRIMITIVE(pf_stack_list_randompermute)
{
    int i, range;
    pf_list_t *l;
    pf_atom_t *a, *b;
    CHECKN(1);
    if (!(pf_atom_islist(ARG0))) return e_type;
    l = ARG0->w.w_list;
    if (l->elements <= 1) EXIT;

    /* randomly swap each element from (0:i) with one from (i+1:l-1) */
    a = l->first;             // target atom
    range = l->elements - 1;  // range of possible swap targets
    for (i=0; i<l->elements-1; i++){
	int r = rand() % range;
	b = a->next;
	while (r--) b=b->next;
	swapatom(a,b);
	a = a->next;
	range--;
    }

    EXIT;
    
}


// indexed list access ( list n - list l[n] )
PF_PRIMITIVE(pf_stack_list_index){
    pf_atom_t *a;
    int n;
    CHECK2(a_int, a_list);
    a = ARG1->w.w_list->first;
    n = ARG0->w.w_int;
    while (n--){
	if (!a) return e_list;
	a = a->next;
    }
    if (!a) return e_list;
    DROP1;
    pf_stack_push_atom(s, a);
    EXIT;

}

// reverse a list
PF_PRIMITIVE(pf_stack_list_reverse){
    pf_atom_t *a;
    int n;
    CHECK1(a_list);
    pf_list_reverse(ARG0->w.w_list);
    EXIT;
}

PF_PRIMITIVE(pf_stack_atom_follow){
    pf_atom_t *a;
    CHECK1(a_atom_pointer);
    a = ARG0->w.w_atom_pointer;
    if (!a || pf_atom_stale(a)) THROW(e_pointer, "following NULL variable (end of atom list?)");
    ARG0->w.w_atom_pointer = a->next;
    EXIT;
}


/* conversion methods. they convert TOS to the specified type. 
   they use the type specific pops to do this */

/* convert to int */
PF_PRIMITIVE(pf_stack_int)
{
    int i;
    char *string;
    if (!ARG0) return e_underflow;
    switch(ARG0->t){
    default: 	  return e_type;
    case a_int:	  EXIT;
    case a_float:
	ARG0->t = a_int;
	ARG0->w.w_int = (int)ARG0->w.w_float;
	EXIT;
    case a_packet:
	string = STRING(ARG0);
	if (!string) return e_type;
	else {
	    i = strtol(string, 0, 0);
	    DROP1;
	    PUSH_INT(i);
	    EXIT;
	}
    }
}

/* convert to float */
PF_PRIMITIVE(pf_stack_float)
{
    float f;
    char *string;
    if (!ARG0) return e_underflow;
    switch(ARG0->t){
    default: 	  return e_type;
    case a_float: EXIT;
    case a_int:
	ARG0->t = a_float;
	ARG0->w.w_float = (float)ARG0->w.w_int;
	EXIT;
    case a_packet:
	string = STRING(ARG0);
	if (!string) return e_type;
	else {
	    f = strtod(string, 0);
	    DROP1;
	    PUSH_FLOAT(f);
	    EXIT;
	}
    }
}

/* convert raw atom to pointer: use with care */
PF_PRIMITIVE(pf_stack_pointer)
{
    if (!ARG0) return e_underflow;
    ARG0->t = a_pointer;
    EXIT;
}

/* convert a string to a symbol */
PF_PRIMITIVE(pf_stack_symbol)
{
    CHECK1(a_packet);
    char *string = STRING(ARG0);
    if (!string) return e_type;
    pf_symbol_t *sym = pf_symbol(string);
    DROP1;
    PUSH_SYMBOL(sym);
    EXIT;
}

/* convert a string to a symbol */
PF_PRIMITIVE(pf_stack_symbolsize)
{
    CHECK1(a_symbol);
    PUSH_INT(strlen(ARG0->w.w_symbol->s_name));
    EXIT;
}


/* convert anything to string */
PF_PRIMITIVE(pf_stack_string)
{
    char *c;
    pf_packet_t p;
    pf_atom_t *a;
    CHECKN(1);
    if (!ARG0) return e_underflow;
    a = ARG0;
    switch(a->t){
    case a_packet: // is it already a string ?
	c = pf_packet_string_data(a->w.w_packet);
	if (!c) return e_type;	else EXIT;
    case a_symbol: 
	p = pf_packet_stringf("%s", a->w.w_symbol->s_name); 
	goto replace;
    case a_float:
	p = pf_packet_stringf("%.2f", a->w.w_float);
	goto replace;
    case a_int:
	p = pf_packet_stringf("%d", a->w.w_int);
	goto replace;
    default:
	break;
    }
    return e_type; // fallthrough

  replace:
    DROP1;
    PUSH_PACKET(p);
    EXIT;

}

#include <sys/time.h>
#include <time.h>

/* seed random number generator based on current time */
PF_PRIMITIVE(pf_stack_seed){
    struct timeval tv;
    gettimeofday(&tv, 0);
    unsigned int seed = tv.tv_usec;
    srand(seed);
    EXIT;
}

/* random integer with range 0 .. TOS-1 */
PF_PRIMITIVE(pf_stack_rand)
{
    unsigned int r = rand();
    if (!ARG0) return e_underflow;
    switch(ARG0->t){
    default: return e_type;
    case a_int:
	ARG0->w.w_int = r % ARG0->w.w_int;
	EXIT;
    case a_float:
	ARG0->w.w_float *= (float)r / (float)RAND_MAX;
	EXIT;
    }
}

/* get a 2 floats from a normal distribution */
PF_PRIMITIVE(pf_stack_2normal)
{
    float a = ((float)rand()) * (2.0f * M_PI * (1.0f / ((float)RAND_MAX)));
    float r = ((float)(1 + rand())) * (1.0f / ((float)RAND_MAX));
    float x = cos(a);
    float y = sin(a);
    r = sqrt(-2.0f * log(r));
    PUSH_FLOAT(x*r);
    PUSH_FLOAT(y*r);
    EXIT;
}


/*
  something i changed after being very annoyed by it..

  int int -> int

  int float -> float
  float int -> float
  float float -> float

  the first one is the standard int one, needs to be the first one
  that's tried in the polyword!

  the second one accepts floats.

  this results in 2 checking / converting routines


 */

static void int_to_float(pf_atom_t *a){
    if (a->t == a_int){
	a->w.w_float = (float)a->w.w_int;
	a->t = a_float;
    }
}

static PF_PRIMITIVE(pf_stack_1op_int){
    CHECK1(a_int);
    EXIT;
}
static PF_PRIMITIVE(pf_stack_1op_float){
    CHECKN(1);
    int_to_float(ARG0);
    CHECK1(a_float);
    EXIT;
}

static PF_PRIMITIVE(pf_stack_2op_int){
    CHECK2(a_int, a_int);
    EXIT;
}
static PF_PRIMITIVE(pf_stack_2op_float){
    CHECKN(2);
    int_to_float(ARG0);
    int_to_float(ARG1);
    CHECK2(a_float, a_float);
    EXIT;
}

#define CHECK_2OP(type) { pf_error_t e = PF_EXEC_PRIMITIVE(pf_stack_2op_##type); if (e) return e; }
#define CHECK_1OP(type) { pf_error_t e = PF_EXEC_PRIMITIVE(pf_stack_1op_##type); if (e) return e; }

/* type specific stuff
   these need to check for stack AND type errors */

#define OP1(name, type, op)				\
PF_PRIMITIVE(pf_stack_##name##_##type)		\
{							\
    CHECK_1OP(type);			\
    ARG0->w.w_##type = op (ARG0->w.w_##type);	\
    EXIT;					\
}

#define OP2(name, type, op)				\
PF_PRIMITIVE(pf_stack_##name##_##type)		\
{							\
    type x0;						\
    CHECK_2OP(type);		\
    pf_stack_pop_##type (s, &(x0));			\
    ARG0->w.w_##type = ARG0->w.w_##type op x0;	\
    EXIT;					\
}

// conditional assignment
#define OPCA(name, type, op)				\
PF_PRIMITIVE(pf_stack_##name##_##type)		\
{							\
    type x0;						\
    CHECK_2OP(type);		\
    pf_stack_pop_##type (s, &(x0));			\
    ARG0->w.w_##type = (ARG0->w.w_##type op x0) ? ARG0->w.w_##type : x0;	\
    EXIT;					\
}

#define OP2COMP(name, type, op)			\
PF_PRIMITIVE(pf_stack_##name##_##type)	\
{						\
    type x0, x1;				\
    CHECK_2OP(type);	\
    pf_stack_pop_##type (s, &(x0));		\
    pf_stack_pop_##type (s, &(x1));		\
    int retval = (x1 op x0) ? -1 : 0;		\
    pf_list_push_int (s, retval);		\
    EXIT;				\
}

static float inverse(float f){return 1.0f / f;}

// float and int
OPCA(max, float, >);
OPCA(min, float, <);
OP1(abs, float, fabs);
OPCA(max, int, >);
OPCA(min, int, <);

OP2COMP(gt,  int, >);
OP2COMP(gte, int, >=);
OP2COMP(lt,  int, <);
OP2COMP(lte, int, <=);
OP2COMP(gt,  float, >);
OP2COMP(gte, float, >=);
OP2COMP(lt,  float, <);
OP2COMP(lte, float, <=);

OP1(abs, int, abs);
OP2(add, float, +);
OP2(sub, float, -);
OP2(mul, float, *);
OP2(div, float, /);
OP2(add, int, +);
OP2(sub, int, -);
OP2(mul, int, *);
OP2(div, int, /);

// float only
OP1(inverse, float, inverse);
OP1(sqrt, float, sqrt);
OP1(sin, float, sin);
OP1(asin, float, asin);
OP1(cos, float, cos);
OP1(acos, float, acos);
OP1(exp, float, exp);
OP1(log, float, log);
OP1(tan, float, tan);
OP1(atan, float, atan);

// int only
OP2(shl, int, <<);
OP2(shr, int, >>);
OP2(and, int, &);
OP2(or, int, |);
OP2(xor, int, ^);
OP1(not, int, !);



/* special int ops */
PF_PRIMITIVE(pf_stack_ilog2)
{
    CHECK1(a_int);
    int i = ARG0->w.w_int;
    int l = -1;
    if (i < 1) return e_inval;
    while(i){
	i >>= 1;
	l++;
    }
    ARG0->w.w_int = l;   
    EXIT;
}

PF_PRIMITIVE(pf_stack_iexp2)
{
    CHECK1(a_int);
    int l = ARG0->w.w_int;
    int i = 1;
    if (l < 0) return e_inval;
    while(l){
	i <<= 1;
	l--;
    }
    ARG0->w.w_int = i;   
    EXIT;
}


/* int and float math */
PF_PRIMITIVE(pf_stack_fixedpoint){
    CHECK1(a_float);
    float f = ARG0->w.w_float;
    int shift = 0;
    while (fabs(f) > 1.0f) {
	f *= 0.5f;
	shift++;
    }
    ARG0->w.w_float = f;
    PUSH_INT(shift);
    EXIT;
}


PF_PRIMITIVE(pf_stack_mod_int){
    int x0, x1;			      
    CHECK2(a_int, a_int);
    pf_stack_pop_int (s, &(x0));
    pf_stack_pop_int (s, &(x1));
    int retval = (x1 % x0);
    if (retval < 0) retval += x0;
    pf_list_push_int (s, retval);
    EXIT;   
}

PF_PRIMITIVE(pf_stack_mod_float){
    float x0, x1;			      
    CHECK2(a_float, a_float);
    pf_stack_pop_float (s, &(x0));
    pf_stack_pop_float (s, &(x1));
    
    float quot   = x1 / x0;
    int iquot    = (int)quot;
    float retval = x1 - x0 * ((float)iquot);

    if (retval < 0) retval += x0;
    pf_list_push_float (s, retval);
    EXIT;   
}

/* FIXME: sawtooth modulo
   this can serve to implement ping-pong wraparound
*/
PF_PRIMITIVE(pf_stack_mirror_float){
    float x0, x1;			      
    CHECK2(a_float, a_float);
    pf_stack_pop_float (s, &(x0));
    pf_stack_pop_float (s, &(x1));
    
    float quot   = x1 / x0;
    int iquot    = (int)quot;
    float retval = x1 - x0 * ((float)iquot);

    if (retval < 0){
	retval += x0;
	iquot += 1;
    }

    if (iquot & 1) retval = x0 - retval;

    pf_list_push_float (s, retval);
    EXIT;   
}



/* /\* hashes *\/ */
/* PF_PRIMITIVE(pf_stack_hash_test) */
/* { */
/*     CHECK2(a_int, a_list); */
/*     int logsize = pf_list_pop(s).w_int; */
/*     pf_list_t *l = pf_list_pop(s).w_list; */
/*     pf_hash_t *h = pf_hash_new(logsize); */
/*     int i = 0; */

/*     while (l->elements){ */
/* 	pf_atom_t *a=pf_list_pop_atom(l); */
/* 	PF_ASSERT(a->t == a_symbol); */
/* 	pf_symbol_t *s = a->w.w_symbol; */
/* 	a->t = a_int; */
/* 	a->w.w_int = 123; */
/* 	pf_hash_add(h, s, a); */
/*     } */

/*     i = 1 << (h->logsize); */
/*     while (i--){ */
/* 	pf_post("%d ", h->table[i]->elements / 2); */
/*     } */

/*     pf_hash_free(h); */
/*     pf_list_free(l); */
    
/*     EXIT; */
/* } */








/* load undefined atom */
PF_PRIMITIVE(pf_stack_push_undef)
{
    pf_list_push(s, a_undef, (pf_word_t)0);
    EXIT;
}

/* load null pointer */
PF_PRIMITIVE(pf_stack_push_null)
{
    pf_list_push(s, a_atom_pointer, (pf_word_t)0);
    EXIT;
}
/* some packet words */
PF_PRIMITIVE(pf_stack_push_invalid_packet)
{
    PUSH_PACKET(-1);
    EXIT;
}

/* is invalid packet == is packet and is invalid */
// FIXME: take this out, make sure invalid packets never make it to forth
PF_PRIMITIVE(pf_stack_is_invalid_packet)
{
    CHECKN(1);
    if (ARG0->t == a_packet && (!ARG0->w.w_packet)) {
	PUSH_INT(1);
    }
    else {
	PUSH_INT(0);
    }
    EXIT;
}

/* is invalid packet == is packet and is invalid */
PF_PRIMITIVE(pf_stack_is_string)
{
    CHECKN(1);
    if (ARG0->t != a_packet) { PUSH_INT(0); }
    else if (!pf_packet_string_data(ARG0->w.w_packet)) { PUSH_INT(0); }
    else { PUSH_INT(1); }
    EXIT;
}

/* create a new packet using the type symbol in TOS 

   actually, it doesn't really make sense to do this in highlevel
   forth code, since packets will be uninitialized..

   NOTE: creating string packets will return an empty string
   and using that will crash the system.
*/
PF_PRIMITIVE(pf_stack_new_packet)
{
    pf_symbol_t *type;
    pf_atom_t *a = ARG0;
    pf_packet_t p = 0;
    if (!ARG0) return e_underflow;
    if (ARG0->t == a_list){
	type = pf_typesymbol_from_list(ARG0->w.w_list);
    }
    else if (ARG0->t == a_symbol){
	type = a->w.w_symbol; 
    }
    p = pf_factory_newpacket(type);
    if (!p){
	THROW(e_inval, "can't create packet of type %s", type->s_name);
    }
    DROP1;
    PUSH_PACKET(p);
    EXIT;
}

#if 0
PF_PRIMITIVE(pf_stack_convert_packet)
{
    pf_symbol_t *type;
    int packet;
    pf_atom_t *a = ARG0;
    CHECKN(2);
    if (ARG1->t != a_packet) return e_type;
    packet = ARG1->w.w_packet;
    if (ARG0->t == a_list){
	type = pf_typelist_to_typesymbol(ARG0->w.w_list);
    }
    else if (ARG0->t == a_symbol){
	type = a->w.w_symbol; 
    }
    DROP1;
    packet = pf_packet_convert(packet, type);
    DROP1;
    PUSH_PACKET(packet);
    EXIT;
}
#endif


/* replace packet with clone.
   for other types equivalent to dup. */
PF_PRIMITIVE(pf_stack_packet_clone)
{
    if (!ARG0) return e_underflow;
    if (ARG0->t != a_packet)
	// if not packet -> delegate to dup
	return pf_stack_dup(s);

    PUSH_PACKET(pf_packet_clone(ARG0->w.w_packet));
    EXIT;
}


/* push mime type (description) */
PF_PRIMITIVE(pf_stack_packet_mime_list)
{
    pf_list_t *type;
    pf_header_t *header;
    CHECK1(a_packet);
    header = pf_packet_header(ARG0->w.w_packet);
    if (header && header->desc) {
	PUSH_LIST(pf_list_from_typesymbol(header->desc));
    }
    else { 
	PUSH_LIST(pf_list_new());
    }
    EXIT;
}


/* the = operator */
PF_PRIMITIVE(pf_stack_equals)
{ 
    int flag;
    CHECKN(2);
    if (ARG0->t != ARG1->t){
	// this used to be an error, but comparing
	// different types really should return non-equal
	flag = 0;
    }
    else {
	flag = (ARG0->w.w_int == ARG1->w.w_int) ? -1 : 0;

	switch (ARG0->t){
	    /* basic types : need to match bit by bit */
	case a_int:
	case a_pointer:
	case a_atom_pointer:
	case a_symbol:
	case a_error:
	    break;
	case a_undef:
	    /* undefined: don't care about contents of word */
	    flag = -1;
	    break;

	    /* packets need to be handled elsewhere if they are not*/
	case a_packet:
	    if (!flag) return e_type; // another comparator (polyword) should handle
	    break;

	case a_list: // not supported here
	default:
	    return e_type; // other types need to override this operator
	}
    }

  done:
    DROP1;
    DROP1;
    PUSH_INT(flag);
    EXIT;
}


/* push TOS's type on stack */
PF_PRIMITIVE(pf_stack_type)
{
    if (s->elements < 1) return e_underflow;
    PUSH_SYMBOL(pf_atom_typesymbol(ARG0));
    EXIT;
}

/* nop */
PF_PRIMITIVE(pf_stack_nop){EXIT;}

/* nop */
PF_PRIMITIVE(pf_stack_to_xt){
    CHECKN(1);
    switch(ARG0->t){
    case a_atom_pointer:
	ARG0->t = a_forth_xt;
	EXIT;
    default:
	return e_type;
    }
}


PF_PRIMITIVE(pf_string){
    PUSH_PACKET(pf_packet_string_buffer(10)); //FIXME: arbitrary
    EXIT;
}

/* reserve packet : make mutable */
/* PF_PRIMITIVE(pf_stack_reserve){ */
/*     CHECK1(a_packet); */
/*     pf_packet_t p = pf_packet_reserve(&ARG0->w.w_packet); */
/*     if (!p){ */
/* 	pf_header_t *h = pf_packet_header(ARG0->w.w_packet); */
/* 	THROW(e_inval, "cannot copy packets of type %s", h->desc->s_name); */
/*     } */
/*     EXIT; */
/* } */



/* SETUP CODE */

/* local init */
static void _forth_word(char *name, pf_forth_primitive_t word){
    pf_vm_add_primitive(pf_forth_vm(), pf_symbol(name), word);
}
static void _poly_word(char* polyname, char *name, pf_forth_primitive_t word){
    _forth_word(name, word);
    //pf_vm_add_to_polyword(pf_forth_vm, pf_symbol(polyname), word);  // CLEANUP LATER WHILE ADDING DOC STRINGS
}
#define REGISTER_PRIMITIVE PF_REGISTER_FUNCTION
#define FIXME_REG_PRIM(x,y) REGISTER_PRIMITIVE(y,x,"")

void pf_forth_basic(void)
{
    pf_vm_t *vm = pf_forth_vm();
    /* general purpose stack words */
    REGISTER_PRIMITIVE(pf_stack_dup,  "dup",  "( a -- a a )\tDuplicate item.");
    REGISTER_PRIMITIVE(pf_stack_swap, "swap", "( a b -- b a)\tExchange 2 top items.");
    REGISTER_PRIMITIVE(pf_stack_drop, "drop", "( a -- )\tDiscard top item.");

    REGISTER_PRIMITIVE(pf_stack_over, "over", "( a b -- a b a )\tDuplicate 2nd item.");
    REGISTER_PRIMITIVE(pf_stack_pick, "pick", "( index -- thing )\tIndexed data stack access. Avoid using this.");

    REGISTER_PRIMITIVE(pf_string,     "string",    "( -- string )\tCreate a new string.");



    /* indirect list ops. */

    REGISTER_PRIMITIVE(pf_stack_plist_remove, "remove",      "( thing listvar -- )\tRemove a thing from a list.");
    REGISTER_PRIMITIVE(pf_stack_plist_contains, "contains?",      "( thing listvar -- ? )\tDoes list contain element?");
    REGISTER_PRIMITIVE(pf_stack_plist_insert, "insert",       "( thing position listvar -- )\tInsert thing in list contained in variable.");
    REGISTER_PRIMITIVE(pf_stack_plist_push,   "push",        "( thing listvar -- )\tPush thing to list contained in variable. Inserts before the head of the list.");
    REGISTER_PRIMITIVE(pf_stack_plist_queue,  "queue",       "( thing listvar -- )\tEnqueue thing in list in varable. Appends after the tail of the list.");
    REGISTER_PRIMITIVE(pf_stack_plist_pop,    "pop",         "( listvar -- thing )\tPop a thing from a list in a variable. Removes the head of the list.");
    REGISTER_PRIMITIVE(pf_stack_plist_head,   "head",           "( listvar -- headvar )\tGet a pointer to the first element of a list.");
    REGISTER_PRIMITIVE(pf_stack_plist_tail,   "tail",           "( listvar -- tailvar )\tGet a pointer to the last element of a list.");

    REGISTER_PRIMITIVE(pf_stack_plist_atfind, "@find",       "( listvar -- var )\tSearch a double list and return variable.");
    REGISTER_PRIMITIVE(pf_stack_plist_trunc,  "trunc",       "( size listvar -- )\tResize a list in variable (truncate / expand).");
    REGISTER_PRIMITIVE(pf_stack_plist_resize, "queue-size!", "( size listvar -- )\tResize a list in variable by either 'dup' or 'drop' ops. Empty list will contain 'undef'. Mainly for delay lines.");



    /* direct list ops */
    REGISTER_PRIMITIVE(pf_stack_pack,                "list:pack",   "( ... n -- list )\tPack n elements into list.");
    REGISTER_PRIMITIVE(pf_stack_unpack,              "list:unpack", "( list -- ... )\tUnpack list elements.");
    REGISTER_PRIMITIVE(pf_stack_list_reverse,        "list:reverse",   "( list -- list )\tReverse the order of the elements in a list.");
    REGISTER_PRIMITIVE(pf_stack_list_randompermute,  "list:shuffle",   "( list -- list )\tPerform a random permutation of the elements in a list.");
    REGISTER_PRIMITIVE(pf_stack_list_permute,        "list:perm",      "( permid list -- list)\tPermute elements in a list. The permid is an (abstract) permutation id.");
    REGISTER_PRIMITIVE(pf_stack_list_transpose,      "list:transpose", "( list -- list )\tChange inner/outer dimensions for a 2D list structure.");
    REGISTER_PRIMITIVE(pf_stack_list_size,           "list:size",      "( list -- list size )\tReturn the number of elements in a list.");

    REGISTER_PRIMITIVE(pf_stack_atom_follow,         "follow",         "( atompointer -- atompointer )\tChase a pointer. (for list traversal).");

    REGISTER_PRIMITIVE(pf_stack_list_join,           "list:concat",    "( list list/atom -- list )\tConatenate lists and/or atoms.");


    /* packet ops */
    // REGISTER_PRIMITIVE(pf_stack_reserve,             "reserve",   "( packet -- packet )\tReserve a packet. This makes a private copy if necessary (for muting operations).");
    REGISTER_PRIMITIVE(pf_stack_push_invalid_packet, "ip",        "( -- packet)\tGet an invalid packet.");
    REGISTER_PRIMITIVE(pf_stack_is_invalid_packet,   "ip?",       "( packet -- packet ? )\tIs packet invalid?.");
    REGISTER_PRIMITIVE(pf_stack_is_string,           "string?",   "( thing -- thing ? )\tIs thing a string?.");
    REGISTER_PRIMITIVE(pf_stack_new_packet,          "new",       "( typelist/symbol -- packet )\tCreate a new packet.");
    REGISTER_PRIMITIVE(pf_stack_packet_clone,        "clone",     "( packet -- packet packet )\tClone a packet.");

    /* types */
    REGISTER_PRIMITIVE(pf_stack_type,                "type",      "( thing -- thing type )\tGet type symbol.");
    REGISTER_PRIMITIVE(pf_stack_packet_mime_list,    "typelist",  "( packet -- packet list )\tGet type description list.");

    /* misc */
    REGISTER_PRIMITIVE(pf_stack_nop,                 "nop",       "( -- )\tDo nothing.");
    REGISTER_PRIMITIVE(pf_stack_push_undef,          "undef",     "( -- undef )\tLoad undefined value.");
    REGISTER_PRIMITIVE(pf_stack_push_null,           "null",      "( -- null )\tLoad null pointer.");
    REGISTER_PRIMITIVE(pf_stack_to_xt,               ">xt",       "( thing -- xt )\tConvert thing to xt.");


    /* type converters (casts) */
    REGISTER_PRIMITIVE(pf_stack_int,    "scalar>int",      "( scalar -- int )\tConvert a scalar value to an integer.");
    REGISTER_PRIMITIVE(pf_stack_float,  "scalar>float",    "( scalar -- float )\tConvert a scalar value to a float.");
    REGISTER_PRIMITIVE(pf_stack_pointer,"scalar>pointer",  "( scalar -- pointer )\tConvert a scalar value to a void pointer.");
    REGISTER_PRIMITIVE(pf_stack_string, "scalar>string",   "( scalar -- string )\tConvert a scalar value to a string.");
    REGISTER_PRIMITIVE(pf_stack_symbol, "scalar>symbol",   "( scalar -- symbol )\tConvert a scalar value to a symbol.");

    /* random numbers */
    REGISTER_PRIMITIVE(pf_stack_seed,    "seed",    "( -- )\tSeed random number generator based on current system time.");  
    REGISTER_PRIMITIVE(pf_stack_rand,    "rand",    "( max -- float )\tDraw a number from a uniform [0..max] distribution.");  
    REGISTER_PRIMITIVE(pf_stack_2normal, "2normal", "( -- float float )\tDraw 2 numbers from a normal distribution (avg = 0, stdev = 1)");

    /* comparison */
    REGISTER_PRIMITIVE(pf_stack_gt_float, "float:>", "");
    REGISTER_PRIMITIVE(pf_stack_lt_float, "float:<", "");
    REGISTER_PRIMITIVE(pf_stack_gte_float, "float:>=", "");
    REGISTER_PRIMITIVE(pf_stack_lte_float, "float:<=", "");

    REGISTER_PRIMITIVE(pf_stack_gt_int, "int:>", "");
    REGISTER_PRIMITIVE(pf_stack_lt_int, "int:<", "");
    REGISTER_PRIMITIVE(pf_stack_gte_int, "int:>=", "");
    REGISTER_PRIMITIVE(pf_stack_lte_int, "int:<=", "");

    /* floating point ops */
    REGISTER_PRIMITIVE(pf_stack_add_float, "float:+", ""); 
    REGISTER_PRIMITIVE(pf_stack_sub_float, "float:-", ""); 
    REGISTER_PRIMITIVE(pf_stack_mul_float, "float:*", ""); 
    REGISTER_PRIMITIVE(pf_stack_div_float, "float:/", ""); 
    REGISTER_PRIMITIVE(pf_stack_mirror_float, "float:mirror", ""); 
    REGISTER_PRIMITIVE(pf_stack_mod_float, "float:mod", ""); 
    REGISTER_PRIMITIVE(pf_stack_mod_float, "float:%", "");

    REGISTER_PRIMITIVE(pf_stack_min_float, "float:min", ""); 
    REGISTER_PRIMITIVE(pf_stack_max_float, "float:max", ""); 

    REGISTER_PRIMITIVE(pf_stack_inverse_float, "float:inverse", ""); 

    REGISTER_PRIMITIVE(pf_stack_sin_float, "float:sin", ""); 
    REGISTER_PRIMITIVE(pf_stack_abs_float, "float:abs", ""); 
    REGISTER_PRIMITIVE(pf_stack_sqrt_float, "float:sqrt", ""); 
    REGISTER_PRIMITIVE(pf_stack_cos_float, "float:cos", ""); 
    REGISTER_PRIMITIVE(pf_stack_exp_float, "float:exp", ""); 
    REGISTER_PRIMITIVE(pf_stack_log_float, "float:log", "");
    REGISTER_PRIMITIVE(pf_stack_tan_float, "float:tan", "");
    REGISTER_PRIMITIVE(pf_stack_atan_float,"float:atan", "");

    REGISTER_PRIMITIVE(pf_stack_acos_float, "float:acos", ""); 
    REGISTER_PRIMITIVE(pf_stack_asin_float, "float:asin", ""); 


    /* integer ops */
    FIXME_REG_PRIM("int:+", pf_stack_add_int);
    FIXME_REG_PRIM("int:-", pf_stack_sub_int);
    FIXME_REG_PRIM("int:*", pf_stack_mul_int);
    FIXME_REG_PRIM("int:/", pf_stack_div_int);
    FIXME_REG_PRIM("int:mod", pf_stack_mod_int);
    FIXME_REG_PRIM("int:%", pf_stack_mod_int);
    FIXME_REG_PRIM("int:<<", pf_stack_shl_int);
    FIXME_REG_PRIM("int:>>", pf_stack_shr_int);

    FIXME_REG_PRIM("int:and", pf_stack_and_int);
    FIXME_REG_PRIM("int:or",  pf_stack_or_int);
    FIXME_REG_PRIM("int:xor", pf_stack_xor_int);
    FIXME_REG_PRIM("int:not", pf_stack_not_int);

    FIXME_REG_PRIM("int:abs", pf_stack_abs_int);
    FIXME_REG_PRIM("int:min", pf_stack_min_int);
    FIXME_REG_PRIM("int:max", pf_stack_max_int);

    FIXME_REG_PRIM("int:log2", pf_stack_ilog2);
    FIXME_REG_PRIM("int:exp2", pf_stack_iexp2);


    FIXME_REG_PRIM("float:fixedpoint", pf_stack_fixedpoint);


    FIXME_REG_PRIM("scalar:=", pf_stack_equals);


    FIXME_REG_PRIM("symbol:size", pf_stack_symbolsize);

    /* hash */
//    FIXME_REG_PRIM("hashtest",pf_stack_hash_test);


    
}