/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/*****************************************************************************\
*                                                                             *
* KLGENERIC.c                                                                 *
*                                                                             *
* Generic routines for all sequences (lists, strings, perhaps hash-tables)    *
* But not implemented as methods, but as case switches                        *
*                                                                             *
*                                                                             *
\*****************************************************************************/
/* To add your types to generic XXX functions 
 * (now XXX is only subseq, replace-seq, nconc, and map),
 * define a Gen_XXX hook function and makes it apply it to your types or call 
 * the previous value of KlGen_XXX if non-NULL and set the global variable
 * KlGen_XXX to this function.
 */

#include "EXTERN.h"
#include "klone.h"
#include "kl_atom.h"
#include "kl_number.h"
#include "kl_list.h"
#include "kl_func.h"
#include "kl_hash.h"
#include "kl_string.h"
#include "INTERN.h"
#include "klgeneric.h"

#ifdef MALLOCDEBUG0
#define MALLOCDEBUG
#endif

/* subseq
 * extracts a sub-sequence
 * (subseq list start [end])
 * start is inclusive (begins at 0), end is exclusive, defaults to end.
 */

KlO
KlSubseq(argc, argv)
    int argc;
    KlList *argv;
{
    int from, to;

    switch (argc) {
    case 3:
	KlMustBeNumber(argv[2], 2);
	to = ((KlNumber) argv[2])->number;
	break;
    case 2:
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }
    KlMustBeNumber(argv[1], 1);
    from = ((KlNumber) argv[1])->number;

    if (KlIsAList(argv[0])) {
	int i, j, size = ((KlList) argv[0])->size;
	KlList newlist;

	if (argc == 2)
	    to = size;
	newlist = KlListNMake(to - from);
	for (i = from, j = 0; i < to; i++, j++) {
	    KlIncRef(newlist->list[j] = ((i < size && i >= 0)
					 ? ((KlList) argv[0])->list[i] : NIL));
	}
	newlist->type = (KlIsAVector(argv[0])) ? KlVectorType : KlListType;
	return (KlO) newlist;

    } else if (KlIsAString(argv[0])) {
	char *p = ((KlString) argv[0])->string;
	char *q;
	int l = KlStringLength(argv[0]);
	int i, j;
	int size;
	KlString s;

	if (argc == 2)
	    to = l;
	if ((size = to - from) < 0) {
	    s = KlStringNMake(0);
	    *(s->string) = '\0';
	    return (KlO) s;
	}
	s = KlStringNMake(size);
	q = s->string;

	if (from >= 0 && to <= l) {	/* normal case */
	    bcopy(p + from, q, size);
	} else {
	    for (i = from, j = 0; i < to; i++, j++) {
		q[j] = (i < l && i >= 0) ? p[i] : ' ';
	    }
	}
	q[size] = '\0';
	return (KlO) s;

    } else if (KlGen_subseq) {
	return CFAPPLY(KlGen_subseq,  (argc, argv));
    } else {
	return (KlO) KlBadArgument(argv[0], 0, KlTypeErr_StringOrList);
    }
}

/* replace-seq
 * (replace-seq string substring start-pos end-pos)
 * works on string or lists, replaces elts from start to pos by the substring
 * returns the string which is physically modified
 * start is inclusive (begins at 0), end is exclusive.
 */

KlO
KlReplaceSeq(obj, subobj, start, end)
    KlO obj, subobj;
    KlNumber start, end;
{
    int size = (obj->type[KlSelLength] == KlUndefinedMethod1 ? -1 :
		((KlNumber) KlSend_length(obj))->number);
    KlMustBeNumber(start, 2);
    KlMustBeNumber(end, 3);
    if (size != -1) {			/* bounds check */
	if (start->number < 0 || start->number > size)
	    return KlErrorNumberOutOfRange(start->number, 0, size);
	if (end->number < start->number || end->number > size)
	    return KlErrorNumberOutOfRange(end->number, start->number, size);
    }
    if (KlIsAList(obj)) {
	KlMustBeList(subobj, 1);
	KlReplaceSeq_list(obj, subobj, start->number, end->number);
    } else if (KlIsAModifiableString(obj)) {
	KlMustBeString(subobj, 1);
	KlReplaceSeq_string(obj, subobj, start->number, end->number);
    } else if (KlGen_replace_seq) {
        return CFAPPLY(KlGen_replace_seq, 
		       (obj, subobj, start->number, end->number));
    } else {
        return (KlO) KlBadArgument(obj, 0, KlTypeErr_StringOrList);
    }
    return obj;
}
	
KlReplaceSeq_list(list, sublist, start, end)
    KlList list;
    KlList sublist;
    int start;
    int end;
{
    int delta = sublist->size - (end - start);
    KlO *p, *last, *q;

    for (p = list->list + start, last = list->list + end; p < last; p++)
	KlDecRef(*p);			/* remove old elts */
    
    if (delta > 0) {			/* make room */
	int nsize = list->size + delta;
	list->list = (KlO *) Realloc(list->list, KLSO * nsize);
	list->size = nsize;
	for (q = list->list + nsize, p = q - delta, last = list->list + end;
	     p > last;)
	    *--q = *--p;
    } else if (delta < 0) {		/* delete room */
	int nsize = list->size + delta;
	list->size = nsize;
	for (q = list->list + end + delta, p = q - delta, 
		 last = list->list + nsize;
	     q < last;)
	    *q++ = *p++;
    }
					/* insert sublist */
    for (p = list->list + start, q = sublist->list, last = q + sublist->size;
	 q < last;)
	KlIncRef(*p++ = *q++);
}

KlReplaceSeq_string(string, substring, start, end)
    KlString string;
    KlString substring;
    int start;
    int end;
{
    int delta = KlStringLength(substring) - (end - start);
    char *p, *q, *last;

    if (delta) {
	int nsize = KlModStringLength(string) + delta;
	if (delta > 0) {		/* make room */
	    if (KlHasTrait(string, KlTrait_unreallocable)) {
		return (int) KlError(KlE_NO_APPEND, string);
	    }	    
	    string->string = (char *) Realloc(string->string, nsize+1);
	    string->size = nsize;
	    for (q = string->string + nsize, p = q - delta, 
		 last = string->string + end;
		 p > last;)
		*--q = *--p;
	} else if (delta < 0) {		/* delete room */
	    string->size = nsize;
	    for (q = string->string + end + delta, p = q - delta,
		 last = string->string + nsize;
		 q < last;)
		*q++ = *p++;
	}
	string->string[nsize] = '\0';
    }
    /* insert substring */
    bcopy(substring->string, string->string + start, KlStringLength(substring));
}

/* nconc
 * physically concatenates rest to first argument
 * works for list, strings
 */

KlO
KlNconc(argc, argv)
    int argc;
    KlList *argv;
{
    int i, size;

    if (!argc)
	return NIL;
    if (KlIsAList(argv[0])) {
	KlList list = (KlList) argv[0];
	int j, pos = 0;

	if (list == (KlList) NIL) {
	    return KlError(KlE_NO_PUT, list);
	}

	size = list->size;
	for (i = 1; i < argc; i++) {
	    KlMustBeList(argv[i], i);
	    size += ((KlList) argv[i])->size;
	}
#ifdef MALLOCDEBUG
	if (!(list->list))
	    list->list = size ? (KlO *) Malloc(size * sizeof(KlO)) : 0;
	else
#endif
	    list->list = (KlO *) Realloc(list->list, size * sizeof(KlO));
	pos = list->size;
	for (i = 1; i < argc; i++) {
	    for (j = 0; j < ((KlList) argv[i])->size; j++) {
		KlListStore(list, pos, ((KlList) argv[i])->list[j]);
		pos++;
	    }
	}
	list->size = size;
	return (KlO) list;

    } else if (KlIsAModifiableString(argv[0])) {
	KlString string = (KlString) argv[0];
	int size0;
	char *p, *q;

	if (KlHasTrait(string, KlTrait_unreallocable)) {
	    return (KlO) KlError(KlE_NO_APPEND, string);
	}	
	size = size0 = KlModStringLength(string);
	for (i = 1; i < argc; i++) {
	    KlMustBeString(argv[i], i);
	    size += KlStringLength(argv[i]);
	}
	string->string = (char *) Realloc(string->string, size + 1);
	q = string->string + size0;
	for (i = 1; i < argc; i++) {
	    if (KlIsASymbol(argv[i])) {
		p = ((KlString) argv[i])->string;
		while (*p) *q++ = *p++;
	    } else {
		bcopy(((KlString) argv[i])->string, q,
		      ((KlString) argv[i])->size);
		q += ((KlString) argv[i])->size;
	    }
	}
	*q = '\0';
	KlModStringSetLength(string, size); /* not before if nconc to itself */
	return (KlO) string;

    } else if (KlGen_nconc) {
	return CFAPPLY(KlGen_nconc,  (argc, argv));
    } else {
	return (KlO) KlBadArgument(argv[0], 0, KlTypeErr_StringOrList);
    }
}

/* map
 * important function: allows you to iterate on sequences
 * (map return-type function arglists...)
 * if return-type is nil, argument is discarded
 */

KlO
KlMap(argc, argv)
    int argc;
    KlList *argv;
{
    int i, j, length;
    KlList call;
    KlType destype;
    KlO *restab;

    /* parameter check */
    if (argc < 3) {
	return KlBadNumberOfArguments(argc);
    }
    destype = (NIL == (KlO) argv[0] ? 0 : KlFindType(argv[0]));
    length = ((KlNumber) KlSend_length(argv[2]))->number;
    for (i = 3; i < argc; i++) {
	int objlen = ((KlNumber) KlSend_length(argv[i]))->number;

	if (objlen < length) {
	    length = objlen;
	}
    }

    KlListNMakeZ(call, argc - 1);
    KlIncRef(call->list[0] = (KlO) argv[1]);
    restab = KlAlloca(length);

    if (destype) {			/* we need to store the result */
	for (i = 0; i < length; i++) {
	    for (j = 2; j < argc; j++) {
		KlDecRef(call->list[j - 1]);
		KlIncRef(call->list[j - 1] = KlSend_nth(argv[j], i, 0));
	    }
	    restab[i] = KlApply(call);
	}
    } else {				/* otherwise we can GC in the loop */
	KlGCMark();
	for (i = 0; i < length; i++) {
	    for (j = 2; j < argc; j++) {
		KlDecRef(call->list[j - 1]);
		KlIncRef(call->list[j - 1] = KlSend_nth(argv[j], i, 0));
	    }
	    KlApply(call);
	    KlGC();			/* flushes GC */
	}
	return NIL;
    }

    if (destype == KlListType) {
	return (KlO) KlListKl(length, restab);
    } else if (destype == KlVectorType) {
	return (KlO) KlVectorMake(length, restab);
    } else if (destype == KlStringType) {
	KlString s = KlStringNMake(length);

	for (i = 0; i < length; i++) {
	    KlMustBeNumber(restab[i], i);
	    s->string[i] = ((KlNumber) restab[i])->number;
	}
	s->string[length] = '\0';
	return (KlO) s;
    } else if (KlGen_map) {
	return CFAPPLY(KlGen_map,  (length, restab));
    }
    return (KlO) KlBadArgument(argv[0], 0, KlTypeErr_StringOrList);
}


    
/*****************************************************************************\
* 			    FUNCTIONS DECLARATION                             *
\*****************************************************************************/

KlGenericInit()
{
    KlDeclareSubr(KlSubseq, "subseq", NARY);
    KlDeclareSubr(KlReplaceSeq, "replace-seq", 4);
    KlDeclareSubr(KlNconc, "nconc", NARY);
    KlDeclareSubr(KlMap, "map", NARY);
}