unit utipos_ga;

interface

uses
  Classes, SysUtils, xmatdefs;


// La CadenaADN es una simple secuencia de bits, que está organizada en secuencias de
// WORDs (2 bytes).
type
  TCadenaADN = packed array of word;

const
  BIT_MAS_SIGNIFICATIVO = $8000;
  BIT_MENOS_SIGNIFICATIVO = $0001;

const
  C_COD_BINARY = 0;
  C_COD_GRAY = 1;
  C_COD_UNARY = 2;


type
// Este descriptor supone que el Genotipo es un buffer de nbits y simplemente
// sabe copiar la cadena de bits al buffer en ambos sentidos.
TDescriptorGenotipo = class
  nombre: string; // identificador del parámetro
  nbits: integer;
  constructor Create( nombre_: string; nbits_: integer );
  procedure codificar_ADN( var adn: TCadenaADN; var offset: integer; var mask: word; var Genotipo ); virtual;
  function decodificar_ADN( var Genotipo; var adn: TCadenaADN; var offset: integer; var mask: word ): boolean; virtual;
end;

TDescriptorGenotipoBooleano = class( TDescriptorGenotipo )
  constructor Create( nombre_: string );
end;

{ TDescriptorGenotipoEntero }

TDescriptorGenotipoEntero = class( TDescriptorGenotipo )
  k_min, k_max: integer;
  constructor Create( nombre_: string; k_min_, k_max_: integer );
  procedure codificar_ADN( var adn: TCadenaADN; var offset: integer; var mask: word; var Genotipo ); override;
  function decodificar_ADN( var Genotipo; var adn: TCadenaADN; var offset: integer; var  mask: word ): boolean; override;
  // modifica k para que se cumpla k_Min <= k <= k_Max.
  // si el resultado es 0 no fue necesario modificar k.
  // si es  -1, k era inferior a k_Min y se puso igual a k_Min
  // si es 1, k era mayor que k_Max y se puso a k_Max
  function encajonar( var k: integer ): integer;
end;

TDescriptoresGenotiposEnteros = array of TDescriptorGenotipoEntero;

{ TDescriptorGenotipoReal }

TDescriptorGenotipoReal = class( TDescriptorGenotipo )
  x_min, x_max: NReal;
  dx_presicion: NReal;
  constructor Create( nombre_: string; x_min_, x_max_: NReal; nBits_: integer );
  procedure codificar_ADN( var adn: TCadenaADN; var offset: integer; var mask: word; var Genotipo ); override;
  function decodificar_ADN( var Genotipo; var adn: TCadenaADN; var offset: integer; var  mask: word ): boolean; override;
  // modifica x para que se cumpla x_Min <= x <= x_Max.
  // si el resultado es 0 no fue necesario modificar x.
  // si es  -1, x era inferior a x_Min y se puso igual a x_Min
  // si es 1, x era mayor que x_Max y se puso a x_Max
  function encajonar(var x: NReal): integer;
end;

TDescriptoresGenotiposReales = array of TDescriptorGenotipoReal;


procedure BinaryToGray( var adn: TCadenaADN );
procedure GrayToBinary( var adn: TCadenaADN );
function AsBinaryStr( var adn: TCadenaADN ): string;

// compara de derecha a izquierda los words de ambas cadenas.
// si son iguales retorna CERO.
// si la primer direrencia se da en el word k
// retorna 1 si a1[k] > a2[k] y -1 si a1[k] < a2[k]
function comparar_adn( a1, a2: TCadenaADN ): integer;

implementation


type
  TArrOfWord_ = packed array[0..10240] of word; // solo para typecast



function comparar_adn( a1, a2: TCadenaADN ): integer;
var
  k: integer;
  d: integer;
  res: integer;
begin
  res:= 0;
  for k:= 0 to high( a1 ) do
  begin
    d:= a1[k] - a2[k];
    if d <> 0 then
    begin
      if d > 0 then
       res:= 1
      else
       res:= -1;
      break;
    end;
  end;
  result:= res;
end;

procedure inc_ib(var word_offset: integer; var bit_mask: word );
begin
  if bit_mask = BIT_MAS_SIGNIFICATIVO then
  begin
    inc( word_offset );
    bit_mask:= BIT_MENOS_SIGNIFICATIVO;
  end
  else
   bit_mask:= bit_mask shl 1; // mmm ..
end;

constructor TDescriptorGenotipo.Create( nombre_: string; nbits_: integer );
begin
  inherited Create;
  nombre:= nombre_;
  nbits:= nbits_;
end;

procedure TDescriptorGenotipo.codificar_ADN( var adn: TCadenaADN; var offset: integer; var mask: word; var Genotipo );
var
  jbit, jword: integer;
  m: word;
  uno: boolean;
begin
  m:= BIT_MENOS_SIGNIFICATIVO;
  jword:= 0;
  for jbit:= 1 to nbits do
  begin
    uno:= ( TArrOfWord_( Genotipo )[jword] and m ) <> 0;

    if uno then
    begin
       adn[ offset ] := adn[ offset ] or mask;
    end
    else
       adn[ offset ] := adn[ offset ] and not mask;

    inc_ib( offset, mask );
    inc_ib( jword, m );
  end;
end;


function TDescriptorGenotipo.decodificar_ADN( var Genotipo; var adn: TCadenaADN; var offset: integer; var mask: word ): boolean;
var
  jbit, jword: integer;
  m: word;
  uno: boolean;
begin
  m:= BIT_MENOS_SIGNIFICATIVO;
  jword:= 0;

  for jbit:= 1 to nbits do
  begin
    uno:= ( adn[ offset ] and  mask ) <> 0;

    if uno then
    begin
       TArrOfWord_( Genotipo )[jword] := TArrOfWord_( Genotipo )[jword] or m;
    end
    else
       TArrOfWord_( Genotipo )[jword] := TArrOfWord_( Genotipo )[jword] and not m;

    inc_ib( offset, mask );
    inc_ib( jword, m );
  end;
  result:= true; // a este nivel no hay control de caja
end;




procedure BinaryToGray( var adn: TCadenaADN );
var
  jbit: integer;
  uno: boolean;
  uno_ant: Boolean;
  mask: word;
  offset: integer;
  nbits: integer;

begin
  mask:= BIT_MENOS_SIGNIFICATIVO;
  nbits:= length( ADN ) * 16;


  offset:= 0;
  uno_ant:= ( adn[ offset ] and  mask ) <> 0;
  inc_ib( offset, mask );

  for jbit:= 2 to nbits do // el primer bit queda igual
  begin
    uno:= ( adn[ offset ] and  mask ) <> 0;
    if uno <> uno_ant then
    begin
      if not uno then // si hay un cero lo subo a uno
        adn[ offset ]:= adn[ offset ] xor mask; // invertimos el bit
      uno_ant:= true;
    end
    else
      uno_ant:= false;
    inc_ib( offset, mask );
  end;
end;



procedure GrayToBinary( var adn: TCadenaADN );
var
  jbit: integer;
  uno: boolean;
  uno_ant: Boolean;
  mask: word;
  offset: integer;
  nbits: integer;

begin
  mask:= BIT_MENOS_SIGNIFICATIVO;
  nbits:= length( ADN ) * 16;

  offset:= 0;
  uno_ant:= ( adn[ offset ] and  mask ) <> 0;
  inc_ib( offset, mask );

  for jbit:= 2 to nbits do // el primer bit queda igual
  begin
    uno:= ( adn[ offset ] and  mask ) <> 0;
    if uno <> uno_ant then
      if not uno then // si hay un cero lo subo a uno
        adn[ offset ]:= adn[ offset ] xor mask; // invertimos el bit

    uno_ant:= uno;
    inc_ib( offset, mask );
  end;
end;




function AsBinaryStr( var adn: TCadenaADN ): string;
var
  res: string;
  jbit: integer;
  mask: word;
  offset: integer;
  nbits: integer;

begin
  mask:= BIT_MENOS_SIGNIFICATIVO;
  nbits:= length( ADN ) * 16;

  setlength( res, nbits );

  offset:= 0;

  for jbit:= 1 to nbits do
  begin
    if ( adn[ offset ] and  mask ) <> 0 then
     res[jbit]:= '1'
    else
     res[jbit]:= '0';
    inc_ib( offset, mask );
  end;
  result:= res;
end;


constructor TDescriptorGenotipoBooleano.Create( nombre_: string );
begin
  inherited create( nombre_, 1 );
end;


function calc_nbits( rango: qword ): integer;
var
  m: qword;
  cnt: integer;
begin
  m:= rango;
  cnt:= 0;
  while m > 0 do
  begin
    m:= m shr 1; // ojo, puede depende del orden de los bytes del compilador
    inc( cnt );
  end;
  result:= cnt;
end;


//  k_min, k_max: integer;
constructor TDescriptorGenotipoEntero.Create( nombre_: string; k_min_, k_max_: integer );

var
  rango: qword;
begin
  k_min:= k_min_;
  k_max:= k_max_;
  rango:= ( k_max - k_min );
  inherited create( nombre_, calc_nbits( rango ) );
end;

procedure TDescriptorGenotipoEntero.codificar_ADN( var adn: TCadenaADN; var offset: integer; var mask: word; var Genotipo );
var
  rango: qword;
  r: int64;
begin
  r:= integer( Genotipo );
  rango:= ( r - k_min );
  inherited codificar_ADN( adn, offset, mask, rango );
end;

function TDescriptorGenotipoEntero.decodificar_ADN( var Genotipo; var adn: TCadenaADN; var offset: integer; var mask: word ): boolean;
var
   rango: qword;
   res: integer;
begin
  rango:= 0;
  inherited decodificar_ADN( rango, adn, offset, mask );
  res:= rango + k_min;
  if res > k_max then
  begin
    res:= k_max; // ... lo controlo un poco ... este es el control de CAJA del parámetro
    // retorno FALSE para indicar que puede ameritar declarar INVIABLE el individuo
    // o ajustar el adn.
    result:= false;
  end
  else
    result:= true;
  integer( Genotipo ):= res;
end;

function TDescriptorGenotipoEntero.encajonar(var k: integer): integer;
begin
  if k < k_min then
  begin
    k:= k_Min;
    result:= -1
  end
  else if k > k_max then
  begin
    k:= k_Max;
    result:= 1;
  end
  else
    result:= 0;
end;

constructor TDescriptorGenotipoReal.Create( nombre_: string; x_min_, x_max_: NReal;  nBits_: integer );
var
  rango: QWord;

begin
  x_min:= x_min_;
  x_max:= x_max_;
  rango:= 1;
  rango:= ( rango shl nBits_ ) -1;
  {$IFOPT R+}
  if nBits_ >= 64 then
    raise Exception.Create('nBits = ' + IntToStr(nBits_) + ', no puede ser mayor a 64.');
  {$ENDIF}
  dx_presicion:= ( x_max - x_min )/ rango;
  inherited Create( nombre_, nBits_ );
end;

procedure TDescriptorGenotipoReal.codificar_ADN( var adn: TCadenaADN; var offset: integer; var mask: word; var Genotipo );
var
  rango: QWord;
begin
  rango:=  trunc(( NReal( Genotipo ) - x_min )/ dx_presicion + 0.5 );
  inherited codificar_ADN( adn, offset, mask, rango );
end;

function TDescriptorGenotipoReal.decodificar_ADN( var Genotipo; var adn: TCadenaADN; var offset: integer; var mask: word ): boolean;
var
  rango: QWord;
  res: NReal;
begin
  rango:= 0;
  inherited decodificar_ADN( rango, adn, offset, mask );
  res:= rango * dx_presicion + x_min;
  if res > x_max then
  begin
    res:= x_max; // controlo un poco
    result:= false; // pongo flase para dar la señal de que este ADN decodifica
    // fuera de la caja (antes del ajuste) y que puede conveniro declarar INVIABLE
    // al individuo o retocar el ADN para reflejar el ajuste realizado
    // o dejarlo vivir así, sabiendo que se está creando una multiplicidad en
    // la representación.
  end
  else
    result:= true;
  NReal( Genotipo ):= res;
end;

function TDescriptorGenotipoReal.encajonar(var x: NReal): integer;
begin
  if x < x_min then
  begin
    x:= x_min;
    result:= -1;
  end
  else if x > x_max then
  begin
    x:= x_max;
    result:= 1;
  end
  else
    result:= 0;
end;



end.

