home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / gr3d / mm_mem.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-06-07  |  4.2 KB  |  167 lines
  1. (********************************************)
  2. (*                                          *)
  3. (* Unit MMatrix                             *)
  4. (*                                          *)
  5. (*                                          *)
  6. (*   Skelenten implementation of a matrix   *)
  7. (* unit dynamic allocation of memory.       *)
  8. (*                                          *)
  9. (********************************************)
  10.  
  11. unit MM_MEM;
  12. {$N+,E+}
  13.  
  14. interface
  15.  
  16. type
  17.  
  18.   PMCell = ^TMCell;
  19.   TMCell = integer;
  20.  
  21.   Pmatrix = ^Tmatrix;
  22.   Tmatrix = record
  23.     DimRow ,DimCol: byte;
  24.     buf: PMCell;
  25.   end;
  26.  
  27. const
  28.  
  29.   TMCellSize = SizeOf(TMCell);
  30.  
  31.   procedure MStoreVal(var M: PMatrix; R, C: byte; InVal: TMCell);
  32.   procedure MGetVal(M: PMatrix; R, C: byte; var OutVal: TMCell);
  33.   procedure MIncVal(M: PMatrix; R, C: byte; IncVal: TMCell);
  34.   procedure MExchangeRow(var M: PMatrix; R1, R2: byte);
  35.  
  36.   procedure NewMatrix(var NewM: PMatrix; InitDimRow, InitDimCol: byte);
  37.   procedure DelMatrix(var M: PMatrix);
  38.   procedure MInsert(var M1: PMatrix; M2: PMatrix; R: byte);
  39.   procedure CopyMatrix(M: PMatrix; var Result: PMatrix);
  40.   procedure SubMatrix(M: PMatrix; StartRow, StartCol:
  41.                        byte; SubDimRow, SubDimCol: byte;
  42.                        var Result: PMatrix);
  43.  
  44.   function MBufSize(M: PMatrix): Integer;
  45.   function GetPtr(M: PMatrix; R, C: byte): PMCell;
  46.  
  47. implementation
  48.  
  49. function GetPtr(M: PMatrix; R, C: byte): PMCell;
  50. begin
  51.   GetPtr := Ptr(Seg(M^.buf^), (((R-1 ) * M^.DimCol) + C-1 )*TMCellSize+Ofs(M^.buf^));
  52. end;
  53.  
  54. function MBufSize(M: PMatrix): Integer;
  55. begin
  56.   MBufSize := M^.DimRow * M^.DimCol * SizeOf(TMCell);
  57. end;
  58.  
  59. procedure MStoreVal(var M: PMatrix; R, C: byte; InVal: TMCell);
  60. var
  61.   P: PMCell;
  62. begin
  63.   P := GetPtr(M, R, C);
  64.   P^ := InVal;
  65. end;
  66.  
  67. procedure MGetVal(M: PMatrix; R, C: byte; var OutVal: TMCell);
  68. var
  69.   P: PMCell;
  70. begin
  71.   P := GetPtr(M, R, C);
  72.   OutVal := P^;
  73. end;
  74.  
  75. procedure MIncVal(M: PMatrix; R, C: byte; IncVal: TMCell);
  76. var
  77.   P: PMCell;
  78. begin
  79.   P := GetPtr(M, R, C);
  80.   P^ := P^ + IncVal;
  81. end;
  82.  
  83. procedure MExchangeRow(var M: PMatrix; R1, R2: byte);
  84. var
  85.   TempP: PMCell;
  86.   ColLen: Word;
  87. begin
  88.   ColLen := M^.DimCol*TMCellSize;
  89.   GetMem(TempP, ColLen);
  90.   Move(GetPtr(M, R1, 1)^, TempP^, ColLen);
  91.   Move(GetPtr(M, R2, 1)^, GetPtr(M, R1, 1)^, ColLen);
  92.   Move(TempP^, GetPtr(M, R2, 1)^, ColLen);
  93.   FreeMem(TempP, ColLen);
  94. end;
  95.  
  96. { insert M2 into M1; starting at row R }
  97. procedure MInsert(var M1: PMatrix; M2: PMatrix; R: byte);
  98. var
  99.   I: Integer;
  100.   NewBuf: PMCell;
  101.  
  102.   function NewBufPtr(R, C: Byte): PMCell;
  103.   begin
  104.     NewBufPtr := PMCell(Ptr(Seg(NewBuf^), Ofs(NewBuf^)+((R-1)*M1^.DimCol+(C-1))*TMCellSize));
  105.   end;
  106.  
  107. begin
  108.   if M1^.DimCol <> M2^.DimCol then
  109.     Exit;
  110.  
  111.   GetMem(NewBuf, MBufSize(M1)+MBufSize(M2));
  112.   I := (R-1)*M1^.DimCol*TMCellSize; { size of top half of M1 }
  113.  
  114.   Move(M1^.Buf^,        NewBuf^, I);
  115.   Move(GetPtr(M1,R,1)^, NewBufPtr(R+M2^.DimRow,1)^, MBufSize(M1)-I);
  116.   Move(GetPtr(M2,1,1)^, NewBufPtr(R,1)^, MBufSize(M2));
  117.  
  118.   FreeMem(M1^.buf, MBufSize(M1));
  119.   M1^.buf := NewBuf;
  120.   M1^.DimRow := M1^.DimRow+M2^.DimRow;
  121. end;
  122.  
  123. procedure CopyMatrix(M: PMatrix; var Result: PMatrix);
  124. begin
  125.   DelMatrix(Result);
  126.   NewMatrix(Result, M^.DimRow, M^.DimCol);
  127.   Move(M^.Buf^, Result^.Buf^, MBufSize(M));
  128. end;
  129.  
  130. procedure SubMatrix(M: PMatrix; StartRow, StartCol:
  131.                        byte; SubDimRow, SubDimCol: byte;
  132.                        var Result: PMatrix);
  133. var
  134.   i: byte;
  135. begin
  136.   DelMatrix(Result);
  137.   NewMatrix(Result, SubDimRow, SubDimCol);
  138.   for i := 1 to SubDimRow do
  139.     Move(GetPtr(M, StartRow + i - 1, StartCol)^, GetPtr(Result, i, 1)^, SubDimCol*TMCellSize);
  140. end;
  141.  
  142. procedure NewMatrix(var NewM: PMatrix; InitDimRow, InitDimCol: byte);
  143. var
  144.   MSize: Word;
  145. begin
  146.  
  147.   NewM := New(Pmatrix);
  148.   NewM^.DimRow := InitDimRow;
  149.   NewM^.DimCol := InitDimCol;
  150.   MSize := MBufSize(NewM);
  151.   GetMem(NewM^.buf, MSize);
  152.  
  153.   { Init }
  154.   FillChar(NewM^.buf^, MSize, $0);
  155. end;
  156.  
  157. procedure DelMatrix(var M: PMatrix);
  158. begin
  159.   if M<>nil then
  160.   begin
  161.     if M^.buf <> nil then
  162.       FreeMem(M^.buf, M^.DimRow * M^.DimCol * TMCellSize);
  163.     Dispose(M);
  164.   end;
  165. end;
  166.  
  167. end. {unit}