matrices.pas

ezw的pascal源码

  end;
  destroy_vector(row);
  matrix_max := max;
end;

function abs_matrix_max(m: matrix): element_type;
var
  row: vector;
  i: integer;
  max, temp: element_type;
  error: boolean;
begin
  create_vector(row,m.c,error);
  max := 0;
  for i:=0 to m.r-1 do begin
    get_row(m,i,row);
    temp := abs_vector_max(row);
    if max<temp then max := temp;
  end;
  destroy_vector(row);
  abs_matrix_max := max;
end;

function matrix_min(m: matrix): element_type;
var
  row: vector;
  i: integer;
  min, temp: element_type;
  error: boolean;
begin
  create_vector(row,m.c,error);
  min := get_matrix_element(m,0,0);
  for i:=0 to m.r-1 do begin
    get_row(m,i,row);
    temp := vector_min(row);
    if min>temp then min := temp;
  end;
  destroy_vector(row);
  matrix_min := min;
end;

procedure copy_matrix(src: matrix; var dest: matrix);
var
  i: integer;
begin
  if (src.r=dest.r) and (src.c=dest.c) then begin
    for i:=0 to src.r-1 do begin
      get_row(src,i,vector_ptr(longint(dest.m)+i*SizeOf(vector))^);
    end;
  end;
end;

procedure write_matrix(m: matrix);
var
  i: integer;
begin
  for i:=0 to m.r-1 do begin
    write_vector(vector_ptr(longint(m.m)+i*SizeOf(vector))^);
    writeln;
  end;
end;

procedure normalize_matrix(var m: matrix; norm: real);
var
  min, max: element_type;
  i, j: integer;
  temp: real;
begin
  min := matrix_min(m);
  max := matrix_max(m);
  for i:=0 to m.r-1 do begin
    for j:=0 to m.c-1 do begin
      temp := get_matrix_element(m,i,j);
      if (max-min)>0 then begin
        temp := (temp-min)/(max-min)*norm;
      end
      else begin
        temp := norm;
      end;
      put_matrix_element(m,i,j,Round(temp));
    end;
  end;
end;

procedure unnormalize_matrix(var m: matrix; min, max: element_type);
var
  i, j: integer;
  temp: real;
  norm: element_type;
begin
  norm := matrix_max(m);
  for i:=0 to m.r-1 do begin
    for j:=0 to m.c-1 do begin
      temp := get_matrix_element(m,i,j);
      temp := (temp/norm)*(max-min)+min;
      put_matrix_element(m,i,j,Round(temp));
    end;
  end;
end;

procedure reorder_matrix(src: matrix; var dest: matrix; max_level: integer);
var
  x, x_max, y, y_offset, rd, cd, cd_max: integer;
  step, d: integer;
  level, hlevel, vlevel: integer;
  data: element_type;
begin
  step := 2;
  d := step shr 1;
  rd := src.r-1;
  cd_max := src.c-1;
  hlevel := src.c shr 1;
  vlevel := src.r shr 1;
  level := max_level;
  y_offset := 0;

  put_matrix_element(dest,0,0,get_matrix_element(src,0,0));

  while (level<>0) and (hlevel<>0) and (vlevel<>0) do begin
    for y:=(vlevel shl 1)-1 downto vlevel do begin
      cd := cd_max;
      for x:=(hlevel shl 1)-1 downto hlevel do begin

        data := get_matrix_element(src,rd,cd);(* diagonal coefficients. *)
        put_matrix_element(dest,y,x,data);

        data := get_matrix_element(src,rd,cd-d);(* horizontal coefficients. *)
        put_matrix_element(dest,y,x-hlevel,data);

        data := get_matrix_element(src,rd-d,cd);(* vertical coefficients. *)
        put_matrix_element(dest,y-vlevel,x,data);

        dec(cd,step);
      end;
      dec(rd,step);
    end;
    rd := src.r-1-(step-1);
    cd_max := src.c-(step-1)-1;
    d := step;
    step := step shl 1;
    inc(y_offset,vlevel);
    hlevel := hlevel shr 1;
    vlevel := vlevel shr 1;
    dec(level);
  end;

  if (hlevel<>0) and (vlevel<>0) then begin
    hlevel := src.c shr max_level;
    vlevel := src.r shr max_level;
    y_offset := src.r - vlevel;
    rd := 0;
    for y:=0 to vlevel-1 do begin
      cd := 0;
      for x:=0 to hlevel-1 do begin

        data := get_matrix_element(src,rd,cd);
        put_matrix_element(dest,y,x,data);

        inc(cd,d);
      end;
      inc(rd,d);
    end;
  end;

end;

procedure deorder_matrix(src: matrix; var dest: matrix; max_level: integer);
var
  x, x_max, y, y_offset, rd, cd, cd_max: integer;
  step, d: integer;
  level, hlevel, vlevel: integer;
  data: element_type;
begin
  step := 2;
  d := step shr 1;
  rd := src.r-1;
  cd_max := src.c-1;
  hlevel := src.c shr 1;
  vlevel := src.r shr 1;
  level := max_level;
  y_offset := 0;

  put_matrix_element(dest,0,0,get_matrix_element(src,0,0));

  while (level<>0) and (hlevel<>0) and (vlevel<>0) do begin
    for y:=(vlevel shl 1)-1 downto vlevel do begin
      cd := cd_max;
      for x:=(hlevel shl 1)-1 downto hlevel do begin

        data := get_matrix_element(src,y,x);(* diagonal coefficients. *)
        put_matrix_element(dest,rd,cd,data);

        data := get_matrix_element(src,y,x-hlevel);(* horizontal coefficients. *)
        put_matrix_element(dest,rd,cd-d,data);

        data := get_matrix_element(src,y-vlevel,x);(* vertical coefficients. *)
        put_matrix_element(dest,rd-d,cd,data);

        dec(cd,step);
      end;
      dec(rd,step);
    end;
    rd := src.r-1-(step-1);
    cd_max := src.c-(step-1)-1;
    d := step;
    step := step shl 1;
    inc(y_offset,vlevel);
    hlevel := hlevel shr 1;
    vlevel := vlevel shr 1;
    dec(level);
  end;

  if (hlevel<>0) and (vlevel<>0) then begin
    hlevel := src.c shr max_level;
    vlevel := src.r shr max_level;
    y_offset := src.r - vlevel;
    rd := 0;
    for y:=0 to vlevel-1 do begin
      cd := 0;
      for x:=0 to hlevel-1 do begin

        data := get_matrix_element(src,y,x);
        put_matrix_element(dest,rd,cd,data);

        inc(cd,d);
      end;
      inc(rd,d);
    end;
  end;

end;

procedure test_matrix(m: matrix);
var
  i, j: integer;
begin
  for i:=0 to m.r-1 do begin
    for j:=0 to m.c-1 do begin
      put_matrix_element(m,i,j,i);
    end;
  end;
end;

procedure clear_matrix(var m: matrix);
var
  i, j: integer;
begin
  for i:=0 to m.r-1 do begin
    for j:=0 to m.c-1 do begin
      put_matrix_element(m,i,j,0);
    end;
  end;
end;

procedure absolute_threshold_matrix(var m: matrix; threshold: element_type);
var
  row: vector;
  i: integer;
  error: boolean;
begin
  create_vector(row,m.c,error);
  for i:=0 to m.r-1 do begin
    get_row(m,i,row);
    absolute_threshold_vector(row,threshold);
    put_row(m,i,row);
  end;
  destroy_vector(row);
end;

procedure threshold_matrix(var m: matrix; threshold: element_type);
var
  row: vector;
  i: integer;
  error: boolean;
begin
  create_vector(row,m.c,error);
  for i:=0 to m.r-1 do begin
    get_row(m,i,row);
    threshold_vector(row,threshold);
    put_row(m,i,row);
  end;
  destroy_vector(row);
end;

procedure clip_matrix(var m: matrix; clip_level: element_type);
var
  row: vector;
  i: integer;
  error: boolean;
begin
  create_vector(row,m.c,error);
  for i:=0 to m.r-1 do begin
    get_row(m,i,row);
    clip_vector(row,clip_level);
    put_row(m,i,row);
  end;
  destroy_vector(row);
end;

procedure absolute_clip_matrix(var m: matrix; clip_level: element_type);
var
  row: vector;
  i: integer;
  error: boolean;
begin
  create_vector(row,m.c,error);
  for i:=0 to m.r-1 do begin
    get_row(m,i,row);
    absolute_clip_vector(row,clip_level);
    put_row(m,i,row);
  end;
  destroy_vector(row);
end;

function matrix_psnr(m, ref: matrix): real;
var
  i, j: integer;
  total, x, y, s1, s2, mse: real;
begin
  s1 := 0;
  s2 := 0;
  total := m.r;
  total := total*m.c;
  for i:=0 to m.r-1 do begin
    for j:=0 to m.c-1 do begin
      x := get_matrix_element(ref,i,j);
      y := get_matrix_element(m,i,j);
      s1 := s1 + Sqr(y-x);
      s2 := s2 + Sqr(x);
    end;
  end;
  if total<>0 then mse := s1/total
  else mse := Sqrt(255.0);
  Write('MSE=',mse:1:4,', ');
  if mse<>0 then matrix_psnr := 20.0*( Ln(255.0/Sqrt(mse))/Ln(10.0) )
  else matrix_psnr := 9999;
end;

function matrix_mean(m: matrix): real;
var
  i, j: integer;
  total, mean: real;
begin
  total := m.r;
  total := total*m.c;
  if total<>0 then begin
    mean := 0;
    for i:=0 to m.r-1 do begin
      for j:=0 to m.c-1 do begin
        mean := mean + get_matrix_element(m,i,j);
      end;
    end;
    matrix_mean := mean/total;
  end
  else matrix_mean := -1;
end;

procedure matrix_statistics(m: matrix; var stats: statistics);
var
  i, j: integer;
  mean, mean2, data: real;
begin
  stats.N := m.r;
  stats.N := stats.N*m.c;
  if stats.N<>0 then begin
    mean := 0;
    mean2 := 0;
    for i:=0 to m.r-1 do begin
      for j:=0 to m.c-1 do begin
        data := get_matrix_element(m,i,j);
        mean := mean + data;
        mean2 := mean2 + Sqr(data);
      end;
    end;
    mean := mean/stats.N;
    mean2 := mean2/stats.N;
    stats.mean := mean;
    stats.variance := mean2 - Sqr(mean);
  end
  else begin
    stats.mean := 0;
    stats.variance := -1;
  end;
end;

procedure matrix_shift(m: matrix; shift: element_type);
var
  i, j: integer;
begin
  for i:=0 to m.r-1 do begin
    for j:=0 to m.c-1 do begin
      put_matrix_element(m,i,j,get_matrix_element(m,i,j)+shift);
    end;
  end;
end;



end.