Changeset 37 for trunk/Packages/Common
- Timestamp:
- May 9, 2018, 1:22:44 PM (7 years ago)
- Location:
- trunk
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk
- Property svn:ignore
-
old new 3 3 lib 4 4 backup 5 LibrePaint.exe 6 *.lrj
-
- Property svn:ignore
-
trunk/Packages/Common/UMemory.pas
r28 r37 10 10 type 11 11 12 { T Memory}13 14 T Memory= class12 { TBlock } 13 14 TBlock = class 15 15 private 16 16 FData: PByte; 17 17 FSize: Integer; 18 function GetItem(Index: Integer): Byte; 19 procedure SetItem(Index: Integer; AValue: Byte); 20 procedure SetSize(AValue: Integer); virtual; 21 public 22 procedure Clear(Value: Byte = 0); 23 procedure Assign(Source: TMemory); 18 function GetItem(Index: Integer): Byte; virtual; abstract; 19 procedure SetItem(Index: Integer; AValue: Byte); virtual; abstract; 20 procedure SetSize(AValue: Integer); virtual; abstract; 21 public 22 procedure ReadBlock(Block: TBlock; Position: Integer); virtual; 23 procedure WriteBlock(Block: TBlock; Position: Integer); virtual; 24 procedure Clear(Value: Byte = 0); virtual; 25 procedure Assign(Source: TBlock); virtual; 26 property Size: Integer read FSize write SetSize; 27 property Items[Index: Integer]: Byte read GetItem write SetItem; default; 28 end; 29 30 { TMemory } 31 32 TMemory = class(TBlock) 33 private 34 FData: PByte; 35 FSize: Integer; 36 function GetItem(Index: Integer): Byte; override; 37 procedure SetItem(Index: Integer; AValue: Byte); override; 38 procedure SetSize(AValue: Integer); override; 39 public 40 procedure Clear(Value: Byte = 0); override; 41 procedure Assign(Source: TBlock); override; 24 42 constructor Create; 25 43 destructor Destroy; override; 26 44 property Data: PByte read FData; 27 property Size: Integer read FSize write SetSize;28 property Items[Index: Integer]: Byte read GetItem write SetItem; default;29 45 end; 30 46 … … 42 58 end; 43 59 60 { TBitBlock } 61 62 TBitBlock = class 63 private 64 function GetItem(Index: Integer): Byte; virtual; 65 function GetSize: Integer; virtual; 66 procedure SetItem(Index: Integer; AValue: Byte); virtual; 67 procedure SetSize(AValue: Integer); virtual; 68 public 69 procedure Invert; virtual; 70 function GetInteger: Integer; virtual; 71 procedure SetInteger(Value: Integer); virtual; 72 procedure ReadBlock(Block: TBitBlock; Position: Integer); virtual; 73 procedure WriteBlock(Block: TBitBlock; Position: Integer); virtual; 74 procedure Clear(Value: Byte = 0); virtual; 75 procedure Assign(Source: TBlock); virtual; 76 property Size: Integer read GetSize write SetSize; 77 property Items[Index: Integer]: Byte read GetItem write SetItem; default; 78 end; 79 80 { TBitMemory } 81 82 TBitMemory = class(TBitBlock) 83 private 84 FData: PByte; 85 FSize: Integer; 86 function GetSize: Integer; override; 87 procedure SetSize(AValue: Integer); override; 88 function GetItem(Index: Integer): Byte; override; 89 procedure SetItem(Index: Integer; AValue: Byte); override; 90 public 91 constructor Create; 92 destructor Destroy; override; 93 function GetInteger: Integer; override; 94 procedure SetInteger(Value: Integer); override; 95 procedure Clear(Value: Byte = 0); override; 96 procedure ReadBlock(Block: TBitBlock; Position: Integer); override; 97 procedure WriteBlock(Block: TBitBlock; Position: Integer); override; 98 property Data: PByte read FData; 99 procedure Invert; override; 100 end; 101 102 44 103 implementation 104 105 { TBitMemory } 106 107 procedure TBitMemory.Clear(Value: Byte); 108 begin 109 if (Size and 7) = 0 then begin 110 if Value = 0 then FillChar(FData^, Size shr 3, 0) 111 else FillChar(FData^, Size shr 3, $ff); 112 end else inherited; 113 end; 114 115 procedure TBitMemory.ReadBlock(Block: TBitBlock; Position: Integer); 116 begin 117 if Block is TBitMemory then begin 118 if (Position and 7) = 0 then begin 119 if (Block.Size and 7) = 0 then 120 Move(PByte(FData + Position shr 3)^, TBitMemory(Block).Data^, Block.Size shr 3) 121 else inherited; 122 end else inherited; 123 end else inherited; 124 end; 125 126 procedure TBitMemory.WriteBlock(Block: TBitBlock; Position: Integer); 127 begin 128 if Block is TBitMemory then begin 129 if (Position and 7) = 0 then begin 130 if (Block.Size and 7) = 0 then 131 Move(TBitMemory(Block).Data^, PByte(FData + Position shr 3)^, Block.Size shr 3) 132 else inherited; 133 end else inherited; 134 end else inherited; 135 end; 136 137 procedure TBitMemory.Invert; 138 var 139 I: Integer; 140 begin 141 if (Size and 7) = 0 then begin 142 for I := 0 to (Size shr 3) - 1 do 143 PByte(FData + I)^ := PByte(FData + I)^ xor $ff; 144 end 145 else inherited; 146 147 end; 148 149 function TBitMemory.GetInteger: Integer; 150 var 151 I: Integer; 152 V: Integer; 153 begin 154 Result := 0; 155 I := 0; 156 while (I < 32) and (I < Size) do begin 157 V := FData[I shr 3]; 158 V := V shl I; 159 Result := Result or V; 160 // Result := Result or (FData[I shr 3] shl I); 161 Inc(I, 8); 162 end; 163 if Size < 32 then 164 Result := Result and ((1 shl Size) - 1); 165 end; 166 167 procedure TBitMemory.SetInteger(Value: Integer); 168 var 169 I: Integer; 170 begin 171 I := 0; 172 while (I < 32) and (I < Size) do begin 173 FData[I shr 3] := (Value shr I) and $ff; 174 Inc(I, 8); 175 end; 176 end; 177 178 function TBitMemory.GetSize: Integer; 179 begin 180 Result := FSize; 181 end; 182 183 procedure TBitMemory.SetSize(AValue: Integer); 184 var 185 ByteSize: Integer; 186 begin 187 if AValue = FSize then Exit; 188 FSize := AValue; 189 ByteSize := FSize shr 3; 190 if (FSize and 7) > 0 then Inc(ByteSize); 191 FData := ReAllocMem(FData, ByteSize); 192 end; 193 194 function TBitMemory.GetItem(Index: Integer): Byte; 195 begin 196 if Index >= Size then raise Exception.Create('Out of range'); 197 Result := (PByte(FData + (Index shr 3))^ shr (Index and 7)) and 1; 198 end; 199 200 procedure TBitMemory.SetItem(Index: Integer; AValue: Byte); 201 begin 202 if Index >= Size then raise Exception.Create('Out of range, Size:' + IntToStr(Size) + ', Index:' + IntToStr(Index)); 203 PByte(FData + (Index shr 3))^ := PByte(FData + (Index shr 3))^ and not (1 shl (Index and 7)) 204 or ((AValue and 1) shl (Index and 7)); 205 end; 206 207 constructor TBitMemory.Create; 208 begin 209 FData := nil; 210 end; 211 212 destructor TBitMemory.Destroy; 213 begin 214 FreeMem(FData); 215 inherited Destroy; 216 end; 217 218 { TBitBlock } 219 220 function TBitBlock.GetItem(Index: Integer): Byte; 221 begin 222 Result := 0; 223 end; 224 225 function TBitBlock.GetSize: Integer; 226 begin 227 Result := 0; 228 end; 229 230 procedure TBitBlock.SetItem(Index: Integer; AValue: Byte); 231 begin 232 233 end; 234 235 procedure TBitBlock.SetSize(AValue: Integer); 236 begin 237 end; 238 239 procedure TBitBlock.Invert; 240 var 241 I: Integer; 242 begin 243 for I := 0 to Size - 1 do 244 Items[I] := not Items[I]; 245 end; 246 247 function TBitBlock.GetInteger: Integer; 248 begin 249 Result := 0; 250 end; 251 252 procedure TBitBlock.SetInteger(Value: Integer); 253 begin 254 255 end; 256 257 procedure TBitBlock.ReadBlock(Block: TBitBlock; Position: Integer); 258 var 259 I: Integer; 260 begin 261 for I := 0 to Block.Size - 1 do 262 Block.Items[I] := Items[Position + I]; 263 end; 264 265 procedure TBitBlock.WriteBlock(Block: TBitBlock; Position: Integer); 266 var 267 I: Integer; 268 begin 269 for I := 0 to Block.Size - 1 do 270 Items[Position + I] := Block.Items[I]; 271 end; 272 273 procedure TBitBlock.Clear(Value: Byte); 274 var 275 I: Integer; 276 begin 277 for I := 0 to Size - 1 do 278 Items[I] := Value; 279 end; 280 281 procedure TBitBlock.Assign(Source: TBlock); 282 var 283 I: Integer; 284 begin 285 Size := Source.Size; 286 for I := 0 to Size - 1 do 287 Items[I] := Source.Items[I]; 288 end; 289 290 { TBlock } 291 292 procedure TBlock.ReadBlock(Block: TBlock; Position: Integer); 293 var 294 I: Integer; 295 begin 296 if Position + Block.Size > Size then raise Exception.Create(''); 297 for I := 0 to Block.Size - 1 do 298 Items[I] := Items[Position + I]; 299 end; 300 301 procedure TBlock.WriteBlock(Block: TBlock; Position: Integer); 302 var 303 I: Integer; 304 begin 305 if Position + Block.Size > Size then raise Exception.Create(''); 306 for I := 0 to Block.Size - 1 do 307 Items[Position + I] := Items[I]; 308 end; 309 310 procedure TBlock.Clear(Value: Byte); 311 var 312 I: Integer; 313 begin 314 for I := 0 to Size - 1 do 315 Items[I] := Value; 316 end; 317 318 procedure TBlock.Assign(Source: TBlock); 319 var 320 I: Integer; 321 begin 322 Size := Source.Size; 323 for I := 0 to Size - 1 do 324 Items[I] := Source.Items[I]; 325 end; 45 326 46 327 { TPositionMemory } … … 90 371 end; 91 372 92 procedure TMemory.Assign(Source: TMemory); 93 begin 94 Size := Source.Size; 95 Move(Source.Data^, FData^, Size); 373 procedure TMemory.Assign(Source: TBlock); 374 begin 375 if Source is TMemory then begin 376 Size := Source.Size; 377 Move(TMemory(Source).Data^, FData^, Size); 378 end else inherited; 96 379 end; 97 380
Note:
See TracChangeset
for help on using the changeset viewer.