nuttx-apps/interpreters/bas/var.c

/****************************************************************************
 * Included Files
 ****************************************************************************/

#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"

/****************************************************************************
 * Public Functions
 ****************************************************************************/

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;
}