path: root/apps/interpreters/bas/var.c

/* #includes */ /*{{{C}}}*//*{{{*/
#undef  _POSIX_SOURCE
#define _POSIX_SOURCE   1
#undef  _POSIX_C_SOURCE
#define _POSIX_C_SOURCE 2

#include "config.h"

#include <assert.h>
#ifdef HAVE_GETTEXT
#include <libintl.h>
#define _(String) gettext(String)
#else
#define _(String) String
#endif
#include <math.h>
#include <stdlib.h>

#include "error.h"
#include "var.h"

#ifdef USE_DMALLOC
#include "dmalloc.h"
#endif
/*}}}*/

struct Var *Var_new(struct Var *this, enum ValueType type, unsigned int dim, const unsigned int *geometry, int base) /*{{{*/
{
  unsigned int i;
  size_t newsize;

  this->type=type;
  this->dim=dim;
  this->base=base;
  for (newsize=this->size=1,dim=0; dim<this->dim; ++dim)
  {
    if ((newsize*=geometry[dim])<this->size) return (struct Var*)0;
    this->size=newsize;
  }
  if ((newsize*=sizeof(struct Value))<this->size) return (struct Var*)0;
  if ((this->value=malloc(newsize))==(struct Value*)0) return (struct Var*)0;
  if (dim)
  {
    this->geometry=malloc(sizeof(unsigned int)*dim);
    for (i=0; i<dim; ++i) this->geometry[i]=geometry[i];
  }
  else
  {
    this->geometry=(unsigned int*)0;
  }
  for (i=0; i<this->size; ++i) Value_new_null(&(this->value[i]),type);
  return this;
}
/*}}}*/
struct Var *Var_new_scalar(struct Var *this) /*{{{*/
{
  this->dim=0;
  this->size=1;
  this->geometry=(unsigned int*)0;
  this->value=malloc(sizeof(struct Value));
  return this;
}
/*}}}*/
void Var_destroy(struct Var *this) /*{{{*/
{
  while (this->size--) Value_destroy(&(this->value[this->size]));
  free(this->value);
  this->value=(struct Value*)0;
  this->size=0;
  this->dim=0;
  if (this->geometry)
  {
    free(this->geometry);
    this->geometry=(unsigned int*)0;
  }
}
/*}}}*/
void Var_retype(struct Var *this, enum ValueType type) /*{{{*/
{
  unsigned int i;

  for (i=0; i<this->size; ++i)
  {
    Value_destroy(&(this->value[i]));
    Value_new_null(&(this->value[i]),type);
  }
}
/*}}}*/
struct Value *Var_value(struct Var *this, unsigned int dim, int idx[], struct Value *value) /*{{{*/
{
  unsigned int offset;
  unsigned int i;

  assert(this->value);
  if (dim!=this->dim) return Value_new_ERROR(value,DIMENSION);
  for (offset=0,i=0; i<dim; ++i)
  {
    if (idx[i]<this->base || (idx[i]-this->base)>=this->geometry[i])
    {
      return Value_new_ERROR(value,OUTOFRANGE,_("array index"));
    }
    offset=offset*this->geometry[i]+(idx[i]-this->base);
  }
  assert(offset<this->size);
  return this->value+offset;
}
/*}}}*/
void Var_clear(struct Var *this) /*{{{*/
{
  size_t i;

  for (i=0; i<this->size; ++i)
  {
    Value_destroy(&(this->value[i]));
  }
  if (this->geometry)
  {
    free(this->geometry);
    this->geometry=(unsigned int*)0;
    this->size=1;
    this->dim=0;
  }
  Value_new_null(&(this->value[0]),this->type);
}
/*}}}*/
struct Value *Var_mat_assign(struct Var *this, struct Var *x, struct Value *err, int work) /*{{{*/
{
  enum ValueType thisType=this->type;

  if (work)
  {
    unsigned int i,j;
    int unused=1-x->base;
    int g0,g1;

    assert(x->base==0 || x->base==1);
    assert(x->dim==1 || x->dim==2);
    if (this==x) return (struct Value*)0;
    Var_destroy(this);
    Var_new(this,thisType,x->dim,x->geometry,x->base);
    g0=x->geometry[0];
    g1=x->dim==1 ? unused+1 : x->geometry[1];
    for (i=unused; i<g0; ++i) for (j=unused; j<g1; ++j)
    {
      unsigned int element=x->dim==1 ? i : i*g1+j;

      Value_destroy(&(this->value[element]));
      Value_clone(&(this->value[element]),&(x->value[element]));
      Value_retype(&(this->value[element]),thisType);
    }
  }
  else
  {
    if (Value_commonType[this->type][x->type]==V_ERROR) return Value_new_typeError(err,this->type,x->type);
  }
  return (struct Value*)0;
}
/*}}}*/
struct Value *Var_mat_addsub(struct Var *this, struct Var *x, struct Var *y, int add, struct Value *err, int work) /*{{{*/
{
  enum ValueType thisType=this->type;
  struct Value foo,bar;

  if (work)
  {
    unsigned int i,j;
    int unused=1-x->base;
    int g0,g1;

    assert(x->base==0 || x->base==1);
    assert(x->dim==1 || x->dim==2);
    if (x->base!=y->base || x->dim!=y->dim || x->geometry[0]!=y->geometry[0] || (x->dim==2 && x->geometry[1]!=y->geometry[1])) return Value_new_ERROR(err,DIMENSION);
    if (this!=x && this!=y)
    {
      Var_destroy(this);
      Var_new(this,thisType,x->dim,x->geometry,x->base);
    }
    g0=x->geometry[0];
    g1=x->dim==1 ? unused+1 : x->geometry[1];
    for (i=unused; i<g0; ++i) for (j=unused; j<g1; ++j)
    {
      unsigned int element=x->dim==1 ? i : i*g1+j;

      Value_clone(&foo,&(x->value[element]));
      Value_clone(&bar,&(y->value[element]));
      if (add) Value_add(&foo,&bar,1);
      else Value_sub(&foo,&bar,1);
      if (foo.type==V_ERROR)
      {
        *err=foo;
        Value_destroy(&bar);
        return err;
      }
      Value_destroy(&bar);
      Value_destroy(&(this->value[element]));
      this->value[element]=*Value_retype(&foo,thisType);
    }
  }
  else
  {
    Value_clone(err,x->value);
    if (add) Value_add(err,y->value,0);
    else Value_sub(err,y->value,0);
    if (err->type==V_ERROR) return err;
    Value_destroy(err);
  }
  return (struct Value*)0;
}
/*}}}*/
struct Value *Var_mat_mult(struct Var *this, struct Var *x, struct Var *y, struct Value *err, int work) /*{{{*/
{
  enum ValueType thisType=this->type;
  struct Var foo;

  if (work)
  {
    unsigned int newdim[2];
    unsigned int i,j,k;
    int unused=1-x->base;

    assert(x->base==0 || x->base==1);
    if (x->dim!=2 || y->dim!=2 || x->base!=y->base || x->geometry[1]!=y->geometry[0]) return Value_new_ERROR(err,DIMENSION);
    newdim[0]=x->geometry[0];
    newdim[1]=y->geometry[1];
    Var_new(&foo,thisType,2,newdim,0);
    for (i=unused; i<newdim[0]; ++i) for (j=unused; j<newdim[1]; ++j)
    {
      struct Value *dp=&foo.value[i*newdim[1]+j];

      Value_new_null(dp,thisType);
      for (k=unused; k<x->geometry[1]; ++k)
      {
        struct Value p;

        Value_clone(&p,&(x->value[i*x->geometry[1]+k]));
        Value_mult(&p,&(y->value[k*y->geometry[1]+j]),1);
        if (p.type==V_ERROR)
        {
          *err=p;
          Var_destroy(&foo);
          return err;
        }
        Value_add(dp,&p,1);
        Value_destroy(&p);
      }
      Value_retype(dp,thisType);
    }
    Var_destroy(this);
    *this=foo;
  }
  else
  {
    Value_clone(err,x->value);
    Value_mult(err,y->value,0);
    if (err->type==V_ERROR) return err;
    Value_destroy(err);
  }
  return (struct Value*)0;
}
/*}}}*/
struct Value *Var_mat_scalarMult(struct Var *this, struct Value *factor, struct Var *x, int work) /*{{{*/
{
  enum ValueType thisType=this->type;

  if (work)
  {
    unsigned int i,j;
    int unused=1-x->base;
    int g0,g1;

    assert(x->base==0 || x->base==1);
    assert(x->dim==1 || x->dim==2);
    if (this!=x)
    {
      Var_destroy(this);
      Var_new(this,thisType,x->dim,x->geometry,0);
    }
    g0=x->geometry[0];
    g1=x->dim==1 ? unused+1 : x->geometry[1];
    for (i=unused; i<g0; ++i) for (j=unused; j<g1; ++j)
    {
      unsigned int element=x->dim==1 ? i : i*g1+j;
      struct Value foo;

      Value_clone(&foo,&(x->value[element]));
      Value_mult(&foo,factor,1);
      if (foo.type==V_ERROR)
      {
        Value_destroy(factor);
        *factor=foo;
        return factor;
      }
      Value_destroy(&(this->value[element]));
      this->value[element]=*Value_retype(&foo,thisType);
    }
  }
  else
  {
    if (Value_mult(factor,this->value,0)->type==V_ERROR) return factor;
  }
  return (struct Value*)0;
}
/*}}}*/
void Var_mat_transpose(struct Var *this, struct Var *x) /*{{{*/
{
  unsigned int geometry[2];
  enum ValueType thisType=this->type;
  unsigned int i,j;
  struct Var foo;

  geometry[0]=x->geometry[1];
  geometry[1]=x->geometry[0];
  Var_new(&foo,thisType,2,geometry,0);
  for (i=0; i<x->geometry[0]; ++i) for (j=0; j<x->geometry[1]; ++j)
  {
    Value_destroy(&foo.value[j*x->geometry[0]+i]);
    Value_clone(&foo.value[j*x->geometry[0]+i],&(x->value[i*x->geometry[1]+j]));
    Value_retype(&foo.value[j*x->geometry[0]+i],thisType);
  }
  Var_destroy(this);
  *this=foo;
}
/*}}}*/
struct Value *Var_mat_invert(struct Var *this, struct Var *x, struct Value *det, struct Value *err) /*{{{*/
{
  enum ValueType thisType=this->type;
  int n,i,j,k,max;
  double t,*a,*u,d;
  int unused=1-x->base;

  if (x->type!=V_INTEGER && x->type!=V_REAL) return Value_new_ERROR(err,TYPEMISMATCH5);
  assert(x->base==0 || x->base==1);
  if (x->geometry[0]!=x->geometry[1]) return Value_new_ERROR(err,DIMENSION);
  n=x->geometry[0]-unused;

  a=malloc(sizeof(double)*n*n);
  u=malloc(sizeof(double)*n*n);
  for (i=0; i<n; ++i) for (j=0; j<n; ++j)
  {
    if (x->type==V_INTEGER) a[i*n+j]=x->value[(i+unused)*(n+unused)+j+unused].u.integer;
    else a[i*n+j]=x->value[(i+unused)*(n+unused)+j+unused].u.real;
    u[i*n+j]=(i==j?1.0:0.0);
  }
  d=1.0;

  for (i=0; i<n; ++i) /* get zeroes in column i below the main diagonale */
  {
    max=i;
    for (j=i+1; j<n; ++j) if (fabs(a[j*n+i])>fabs(a[max*n+i])) max=j;
    /* exchanging row i against row max */
    if (i!=max) d=-d;
    for (k=i; k<n; ++k) { t=a[i*n+k]; a[i*n+k]=a[max*n+k]; a[max*n+k]=t; }
    for (k=0; k<n; ++k) { t=u[i*n+k]; u[i*n+k]=u[max*n+k]; u[max*n+k]=t; }
    if (a[i*n+i]==0.0)
    {
      free(a);
      free(u);
      return Value_new_ERROR(err,SINGULAR);
    }
    for (j=i+1; j<n; ++j)
    {
      t=a[j*n+i]/a[i*n+i];
      /* substract row i*t from row j */
      for (k=i; k<n; ++k) a[j*n+k]-=a[i*n+k]*t;
      for (k=0; k<n; ++k) u[j*n+k]-=u[i*n+k]*t;
    }
  }

  for (i=0; i<n; ++i) d*=a[i*n+i]; /* compute determinant */

  for (i=n-1; i>=0; --i) /* get zeroes in column i above the main diagonale */
  {
    for (j=0; j<i; ++j)
    {
      t=a[j*n+i]/a[i*n+i];
      /* subtract row i*t from row j */
      a[j*n+i]=0.0; /* a[j*n+i]-=a[i*n+i]*t; */
      for (k=0; k<n; ++k) u[j*n+k]-=u[i*n+k]*t;
    }
    t=a[i*n+i];
    a[i*n+i]=1.0; /* a[i*n+i]/=t; */
    for (k=0; k<n; ++k) u[i*n+k]/=t;
  }

  free(a);
  if (this!=x)
  {
    Var_destroy(this);
    Var_new(this,thisType,2,x->geometry,x->base);
  }
  for (i=0; i<n; ++i) for (j=0; j<n; ++j)
  {
    Value_destroy(&this->value[(i+unused)*(n+unused)+j+unused]);
    if (thisType==V_INTEGER) Value_new_INTEGER(&this->value[(i+unused)*(n+unused)+j+unused],u[i*n+j]);
    else Value_new_REAL(&this->value[(i+unused)*(n+unused)+j+unused],u[i*n+j]);
  }
  free(u);
  Value_destroy(det);
  if (thisType==V_INTEGER) Value_new_INTEGER(det,d);
  else Value_new_REAL(det,d);

  return (struct Value*)0;
}
/*}}}*/
struct Value *Var_mat_redim(struct Var *this, unsigned int dim, const unsigned int *geometry, struct Value *err) /*{{{*/
{
  unsigned int i,j,size;
  struct Value *value;
  int unused=1-this->base;
  int g0,g1;

  if (this->dim>0 && this->dim!=dim) return Value_new_ERROR(err,DIMENSION);
  for (size=1,i=0; i<dim; ++i) size*=geometry[i];
  value=malloc(sizeof(struct Value)*size);
  g0=geometry[0];
  g1=dim==1 ? 1 : geometry[1];
  for (i=0; i<g0; ++i) for (j=0; j<g1; ++j)
  {
    if (this->dim==0 || i<unused || (dim==2 && j<unused) || i>=this->geometry[0] || (this->dim==2 && j>=this->geometry[1])) Value_new_null(&(value[i*g1+j]),this->type);
    else Value_clone(&value[dim==1 ? i : i*g1+j],&this->value[dim==1 ? i : i*this->geometry[1]+j]);
  }
  for (i=0; i<this->size; ++i) Value_destroy(&this->value[i]);
  free(this->value);
  if (this->geometry==(unsigned int*)0) this->geometry=malloc(sizeof(unsigned int)*dim);
  for (i=0; i<dim; ++i) this->geometry[i]=geometry[i];
  this->dim=dim;
  this->size=size;
  this->value=value;
  return (struct Value*)0;
}
/*}}}*/