// file kernel/x/c/string.c: conversion from and to strings
/*-----------------------------------------------------------------------+
 |  Copyright 2005-2006, Michel Quercia (michel.quercia@prepas.org)      |
 |                                                                       |
 |  This file is part of Numerix. Numerix is free software; you can      |
 |  redistribute it and/or modify it under the terms of the GNU Lesser   |
 |  General Public License as published by the Free Software Foundation; |
 |  either version 2.1 of the License, or (at your option) any later     |
 |  version.                                                             |
 |                                                                       |
 |  The Numerix Library 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  |
 |  Lesser General Public License for more details.                      |
 |                                                                       |
 |  You should have received a copy of the GNU Lesser General Public     |
 |  License along with the GNU MP Library; see the file COPYING. If not, |
 |  write to the Free Software Foundation, Inc., 59 Temple Place -       |
 |  Suite 330, Boston, MA 02111-1307, USA.                               |
 +-----------------------------------------------------------------------+
 |                                                                       |
 |                      Conversion entier <-> chane                     |
 |                                                                       |
 +-----------------------------------------------------------------------*/

/* nombre de chiffres dcimaux par chiffre xlong */
#if HW == 16
#define dec_to_chiffre 4
#define pow_10 10000
#elif HW == 32
#define dec_to_chiffre 9
#define pow_10 1000000000
#elif HW == 64
#define dec_to_chiffre 19
#define pow_10 10000000000000000000UL
#endif

/* longueur maximale d'une chane retourne par xstring_of */
#ifdef c_api
#define max_string SIGN_m
#else
#define max_string (Max_wosize*sizeof(long))
#endif



                         /* +--------------------+
                            |  chane -> entier  |
                            +--------------------+ */


/*
  entre :
  _a = NULL ou pointeur sur entier extensible
  s   = chane de caractres

  sortie :
  a <- valeur de s
  si _a != NULL, *_a <- a
  retourne a

  erreur :
  INVALID_STRING si s contient un caractre non reconnu ou s est vide
  ou rduite au signe et au prfixe

  remarques :
  les signes + et - en dbut de chane sont accepts
  les prfixes 0x, 0X, 0o, 0O, 0b, 0B aprs le signe sont reconnus
  pour une chane hexadcimale, les lettres a..f et A..F sont acceptes
*/

xint xx(copy_string)(xint *_a, char *s) {
    unsigned long b,i,l,n,sa;
    chiffre *x,*y,*z,u,v;
    xint a;
    xx_push_roots_1(_a);
#ifdef caml_api
#define _a __lr._a
#endif

    /* lit le signe */
    l = strlen(s);
    switch(s[0]) {
        case '+' : sa = 0;      s++; l--; break;
        case '-' : sa = SIGN_m; s++; l--; break;
        default  : sa = 0;                break;
    }

    /* lit le prfixe */
    b = 10;
    if ((l >= 2) && (s[0] == '0')) switch(s[1]) {
        case 'x': case 'X': b = 16; s += 2; l -= 2; break;
        case 'o': case 'O': b =  8; s += 2; l -= 2; break;
        case 'b': case 'B': b =  2; s += 2; l -= 2; break;
    }

    /* vrifie qu'il reste des caractres */
    if (l == 0) xx(failwith)(INVALID_STRING);

    /*----------------------------------------  base 10 */
    if (b == 10) {

        /* majore la taille de a et allloue la mmoire de travail */
        n = (l + dec_to_chiffre - 1)/dec_to_chiffre;
        x = xn(alloc)(3*n); y = x+n; z = y+n;

        /* convertit les caractres en paquets de chiffres */
        xn(clear)(x,n);
        for (i=n-1; s[0]; s++, l--) {
            if ((s[0] < '0') || (s[0] > '9')) xx(failwith)(INVALID_STRING);
            x[i] = 10*x[i] + s[0] - '0';
            if ((l%dec_to_chiffre) == 1) i--;
        }

        /* regroupe les paquets deux par deux */
        for (l = 1, y[0] = pow_10; l < n; l <<= 1) {
            if (l > 1) {xn(move)(y,l/2,z); xn(fftsqr)(z,l/2,y);}
            for (i=0; i+2*l <= n; i+=2*l) {
                xn(fftmul)(y,l,x+i+l,l,z);
                xn(add)(z,2*l,x+i,l,x+i);
            }
            if (i+l < n) {
                xn(fftmul)(y,l,x+i+l,n-i-l,z);
                xn(add)(z,n-i,x+i,l,x+i);
            }
        }
    }

    /* ---------------------------------------- base 16 */
    else if (b == 16) {

        /* majore la taille de a et allloue la mmoire de travail */
        n = (l + (HW/4) - 1)/(HW/4);
        x = xn(alloc)(n);

        /* dcode les chiffres */
        xn(clear)(x,n);
        for (i=n-1; s[0]; s++, l--) {
            if      ((s[0] >= '0') && (s[0] <= '9')) x[i] = (x[i] << 4) + s[0] - '0';
            else if ((s[0] >= 'A') && (s[0] <= 'F')) x[i] = (x[i] << 4) + s[0] - 'A' + 10;
            else if ((s[0] >= 'a') && (s[0] <= 'f')) x[i] = (x[i] << 4) + s[0] - 'a' + 10;
            else xx(failwith)(INVALID_STRING);
            if ((l%(HW/4)) == 1) i--;
        }
    }

    /* ---------------------------------------- base 8 */
    else if (b == 8) {

        /* majore la taille de a et allloue la mmoire de travail */
        n = 3*(l/HW) + (3*(l%HW) + HW-1)/HW;
        x = xn(alloc)(n);

        /* dcode les chiffres */
        l = HW - (3*(l%HW))%HW; if (l == HW) l = 0;
        for (i=n-1, u=0; s[0]; s++) {
            if ((s[0] < '0') || (s[0] > '7')) xx(failwith)(INVALID_STRING);
	    v = s[0] - '0';
	    l += 3;
	    if (l >= HW) {
	      l -= HW;
	      x[i] = (u << (3-l)) + (v >> l);
	      i--;
	      }
	    u = (u << 3) + v;
	    }
	}

    /* ---------------------------------------- base 2 */
    else {

        /* majore la taille de a et allloue la mmoire de travail */
        n = (l + HW - 1)/HW;
        x = xn(alloc)(n);

        /* dcode les chiffres */
        xn(clear)(x,n);
        for (i=n-1; s[0]; s++, l--) {
            if ((s[0] < '0') || (s[0] > '1')) xx(failwith)(INVALID_STRING);
            x[i] = (x[i] << 1) + s[0] - '0';
            if ((l%HW) == 1) i--;
        }
    }

    /* ---------------------------------------- recopie le rsultat */
    while ((n) && (!x[n-1])) n--;
    a = xx(enlarge)(_a,n);
    xn(move)(x,n,a->val);
    a->hd = (n) ? n|sa : 0;
    xn(free)(x);
    xx_update_and_return(_a,a);

#undef _a
}

#if defined(ocaml_api) || defined(caml_api)

xint xx(of_string)(char *s) {return xx(copy_string)(xx_null,s);}

#endif

                     /* +-----------------------------+
                        |  entier -> chane dcimale  |
                        +-----------------------------+ */

/* 
   entre :
   a = entier extensible

   sortie :
   retourne la reprsentation dcimale de a

   remarques :
   la chane doit tre libre par appel  free
   la chane cre ne contient pas de zro non significatif
   le signe n'est indiqu que si a < 0
*/

char *xx(string_of)(xint a) {
    long la = xx_lg(a), sa = xx_sgn(a);
    long i,j,k,l[8*sizeof(long)],n;
    int small_bloc;
    chiffre *x,*y,*z,*t,r;
    char *s,*u;

    /* cas a = 0 */
    if (la == 0) {
        s = xx(alloc_string)(1);
        s[0] = '0';
        s[1] = 0;
        return(s);
    }

    /* cas a trop grand */
    if (la >= (max_string-2)/(1+dec_to_chiffre)) {
        s = xx(alloc_string)(19);
        strcpy(s,"<very long number>");
        return(s);
    }

    /*
      mmoire ncessaire :
      la + ceil(la/2) + ceil(la/4) + ... pour les puissances de 10
      la + 1                             pour la copie de a
      ceil(la/2)                         pour le premier quotient
      le nombre de ceil est au plus gal au nombre de bits dans un long
    */
    n = (7*la)/2 + 8*sizeof(long) ;
    x = xn(alloc)(n); z = x+n;

    /* calcule les puissances de pow_10 jusqu' dpasser |a|^1/2 */
    x[0] = pow_10; l[0] = 1;
    for (i=0; 2*l[i]-1 <= la; ) {
        xn(fftsqr)(x,l[i],x+l[i]);
        x += l[i];
        i++;
        for (l[i] = 2*l[i-1]; x[l[i]-1] == 0; l[i]--);
    }

    /* si on a dpass |a|, recule */
    if ((i) && (xn(cmp)(a->val,la,x,l[i]) < 0)) {i--; x -= l[i];}

    /* dcoupe a en blocs < pow_10^2 */
    xn(move)(a->val,la,x+l[i]); n = 1;
    for (; i; i--, x -= l[i]) {

        y = x + l[i] + (n-1)*l[i+1]; t = z;

        /* vrifie que le dernier bloc est suprieur au diviseur */
        small_bloc = (xn(cmp)(y,la,x,l[i]) < 0);

        /* dcale le diviseur pour avoir msb = 1 */
        for(k=0, r=x[l[i]-1]; r < BASE_2; r<<=1, k++);
        if (k) xn(shift_up)(x,l[i],x,k);

        /* premire division */
        if (small_bloc) {t -= la; xn(move)(y,la,t);}
        else {
            if (k) {y[la] = xn(shift_up)(y,la,y,k); la++;}
            la -= l[i];
            t  -= la;
            xn(karpdiv)(y,la,x,l[i],t,1);
            t -= l[i];
            xn(shift_down)(y,l[i],t,k);
        }

        /* divise les autres blocs */
        for (j = 1; j < n; j++) {
            y[0] = 0;
            y -= l[i+1];
            if (k) xn(shift_up)(y,2*l[i],y,k);
            t -= l[i];
            xn(karpdiv)(y,l[i],x,l[i],t,1);
            t -= l[i];
            xn(shift_down)(y,l[i],t,k);
        }

        /* translate les blocs pour les divisions suivantes */
        xn(move)(t,z-t,x);
        n = 2*n - small_bloc;

    }

    /* dcoupe en blocs < pow_10 */
    small_bloc = (xn(cmp)(x+2*n-1,la,x,1) < 0);
    for (j = 1, y = x+1; j < n; j++, y += 2) y[-1] = xn(div_1)(y,2, pow_10,y);
    if (small_bloc) y[-1] = y[0];       else y[-1] = xn(div_1)(y,la,pow_10,y);
    n = 2*n - small_bloc;

    /* calcule la taille de la chane */
    for (r=x[n-1], i=0; r; r /= 10, i++);
    s = xx(alloc_string)((n-1)*dec_to_chiffre + i + (sa != 0));
    u = s;
    if (sa) {u[0] = '-'; u++;}

    /* dcompose le bloc de tte */
    for (r=x[n-1], j=i; j; r /= 10, j--) u[j-1] = '0' + r%10;
    u += i;

    /* dcompose les blocs suivants */
    for (n--; n; n--) {
        for (r = x[n-1], i=dec_to_chiffre; i; r /= 10, i--) u[i-1] = '0' + r%10;
        u += dec_to_chiffre;
    }

    /* termin */
    u[0] = 0;
    xn(free)(x);
    return(s);

}


                       /* +-------------------------+
                          |  entier -> chane hexa  |
                          +-------------------------+ */

/* 
   entre :
   a = entier extensible

   sortie :
   retourne la reprsentation hexadcimale de a

   remarques :
   la chane doit tre libre par appel  free
   les chiffres >= 10 sont cods A..F
   la chane cre ne contient pas de zro non significatif
   le signe n'est indiqu que si a < 0
*/

char *xx(hstring_of)(xint a) {
    long la = xx_lg(a), l;
    char *s,*t;
    chiffre *aa, u,v;
    xx_push_roots_1(a);
#ifdef caml_api
#define a __lr.a
#endif

    /* cas a = 0 */
    if (la == 0) {
        s = xx(alloc_string)(1);
        s[0] = '0';
        s[1] = 0;
        xx_pop_roots();
        return(s);
    }

    /* cas a trop grand */
    if (la >= (max_string-4)/(HW/4)) {
        s = xx(alloc_string)(19);
        strcpy(s,"<very long number>");
        xx_pop_roots();
        return(s);
    }

    /* calcule la longueur de chane ncessaire */
    u = a->val[la-1];
    l = la*HW/4;
    while (u < BASE_2/8) {l--; u <<= 4;}

    /* alloue la chane et copie le signe et le prfixe */
    s = xx(alloc_string)(l + 2 + (xx_sgn(a) != 0));
    t = s;
    if (xx_sgn(a)) {t[0] = '-'; t++;}
    t[0] = '0'; t[1] = 'x'; t+=2;


    /* convertit les chiffres */
    for (aa = a->val + la-1; l; t++) {
        v = u >> (HW-4);
        if (v <= 9) t[0] = v + '0'; else t[0] = v + 'A' - 10;
        l--;
        if (l % (HW/4) == 0) {aa--; u = aa[0];} else u <<= 4;
    }

    t[0] = 0;
    xx_pop_roots();
    return(s);

#undef a
}

                      /* +---------------------------+
                         |  entier -> chane octale  |
                         +---------------------------+ */

/* 
   entre :
   a = entier extensible

   sortie :
   retourne la reprsentation octale de a

   remarques :
   la chane doit tre libre par appel  free
   la chane cre ne contient pas de zro non significatif
   le signe n'est indiqu que si a < 0
*/

char *xx(ostring_of)(xint a) {
    long la = xx_lg(a), i,j,l;
    char *s,*t,v;
    chiffre *aa,u;
    xx_push_roots_1(a);
#ifdef caml_api
#define a __lr.a
#endif

    /* cas a = 0 */
    if (la == 0) {
        s = xx(alloc_string)(1);
        s[0] = '0';
        s[1] = 0;
        xx_pop_roots();
        return(s);
    }

    /* cas a trop grand */
    if (la >= (max_string-4)/((HW+2)/3)) {
        s = xx(alloc_string)(19);
        strcpy(s,"<very long number>");
        xx_pop_roots();
        return(s);
    }

    /* calcule la longueur de chane ncessaire */
    for (u = a->val[la-1], l = la*HW; u < BASE_2; l--, u <<= 1);
    l = (l+2)/3;

    /* alloue la chane et copie le signe et le prfixe */
    s = xx(alloc_string)(l + 2 + (xx_sgn(a) != 0));
    t = s;
    if (xx_sgn(a)) {t[0] = '-'; t++;}
    t[0] = '0'; t[1] = 'o'; t+=2;


    /* convertit les chiffres */
    for (aa = a->val, i=l, u=0, j=0; i; i--) {
      switch(j) {
      case 0:        u = aa[0]; aa++; v  = u&7;        u >>= 3; j = HW-3; break;
      case 1: v = u; u = aa[0]; aa++; v |= (u&3) << 1; u >>= 2; j = HW-2; break;
      case 2: v = u; u = aa[0]; aa++; v |= (u&1) << 2; u >>= 1; j = HW-1; break;
      default:                        v  = u&7;        u >>= 3; j -= 3;
      }
      t[i-1] = '0' + v;
    }

    t[l] = 0;
    xx_pop_roots();
    return(s);

#undef a
}

                     /* +----------------------------+
                        |  entier -> chane binaire  |
                        +----------------------------+ */

/* 
   entre :
   a = entier extensible

   sortie :
   retourne la reprsentation binaire de a

   remarques :
   la chane doit tre libre par appel  free
   la chane cre ne contient pas de zro non significatif
   le signe n'est indiqu que si a < 0
*/

char *xx(bstring_of)(xint a) {
    long la = xx_lg(a), l;
    char *s,*t;
    chiffre *aa, u;
    xx_push_roots_1(a);
#ifdef caml_api
#define a __lr.a
#endif

    /* cas a = 0 */
    if (la == 0) {
        s = xx(alloc_string)(1);
        s[0] = '0';
        s[1] = 0;
        xx_pop_roots();
        return(s);
    }

    /* cas a trop grand */
    if (la >= (max_string-4)/HW) {
        s = xx(alloc_string)(19);
        strcpy(s,"<very long number>");
        xx_pop_roots();
        return(s);
    }

    /* calcule la longueur de chane ncessaire */
    u = a->val[la-1];
    l = la*HW;
    while (u < BASE_2) {l--; u <<= 1;}

    /* alloue la chane et copie le signe et le prfixe */
    s = xx(alloc_string)(l + 2 + (xx_sgn(a) != 0));
    t = s;
    if (xx_sgn(a)) {t[0] = '-'; t++;}
    t[0] = '0'; t[1] = 'b'; t+=2;


    /* convertit les chiffres */
    for (aa = a->val + la-1; l; t++) {
        t[0] = '0' + (u >= BASE_2) ;
        l--;
        if (l % HW == 0) {aa--; u = aa[0];} else u <<= 1;
    }

    t[0] = 0;
    xx_pop_roots();
    return(s);

#undef a
}