├── CoreAtomic.inc ├── CoreClasses.pas ├── CoreEndian.inc ├── PascalStrings.pas ├── README.md ├── UPascalStrings.pas └── zDefine.inc /CoreAtomic.inc: -------------------------------------------------------------------------------- 1 | // used Critical Simulate Atomic with TMonitor.Enter(obj) and TMonitor.Exit(obj) 2 | // CriticalSimulateAtomic defined so performance to be reduced 3 | 4 | // used soft Simulate Critical(ring) 5 | // SoftCritical defined so performance to be reduced 6 | 7 | { * object lock support, create by qq600585 * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/ZServer4D * } 10 | { * https://github.com/PassByYou888/zExpression * } 11 | { * https://github.com/PassByYou888/zTranslate * } 12 | { * https://github.com/PassByYou888/zSound * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/zGameWare * } 15 | { * https://github.com/PassByYou888/zRasterization * } 16 | { ****************************************************************************** } 17 | 18 | constructor TSoftCritical.Create; 19 | begin 20 | inherited Create; 21 | L := False; 22 | end; 23 | 24 | procedure TSoftCritical.Acquire; 25 | {$IFDEF ANTI_DEAD_ATOMIC_LOCK} 26 | var 27 | d: TTimeTick; 28 | {$ENDIF ANTI_DEAD_ATOMIC_LOCK} 29 | begin 30 | {$IFDEF ANTI_DEAD_ATOMIC_LOCK} 31 | d := GetTimeTick; 32 | while L do 33 | if GetTimeTick - d >= 5000 then 34 | RaiseInfo('dead lock'); 35 | {$ELSE ANTI_DEAD_ATOMIC_LOCK} 36 | while L do 37 | NOP; 38 | 39 | L := True; 40 | {$ENDIF ANTI_DEAD_ATOMIC_LOCK} 41 | end; 42 | 43 | procedure TSoftCritical.Release; 44 | begin 45 | L := False; 46 | end; 47 | 48 | type 49 | PCritical_Struct = ^TCritical_Struct; 50 | 51 | TCritical_Struct = record 52 | Obj: TObject; 53 | LEnter: Integer; 54 | LockTick: TTimeTick; 55 | Critical: TCritical; 56 | end; 57 | 58 | TGetCriticalLockState = (lsSame, lsNew, lsIdle); 59 | 60 | var 61 | CoreLockCritical: TCriticalSection; 62 | CoreComputeCritical: TCriticalSection; 63 | CoreTimeTickCritical: TCriticalSection; 64 | CriticalList: TCoreClassList; 65 | 66 | procedure InitCriticalLock; 67 | begin 68 | CoreLockCritical := TCriticalSection.Create; 69 | CoreComputeCritical := TCriticalSection.Create; 70 | CoreTimeTickCritical := TCriticalSection.Create; 71 | CriticalList := TCoreClassList.Create; 72 | end; 73 | 74 | procedure FreeCriticalLock; 75 | var 76 | i: Integer; 77 | p: PCritical_Struct; 78 | begin 79 | for i := 0 to CriticalList.Count - 1 do 80 | begin 81 | p := PCritical_Struct(CriticalList[i]); 82 | p^.Critical.Free; 83 | Dispose(p); 84 | end; 85 | CriticalList.Free; 86 | CriticalList := nil; 87 | 88 | CoreLockCritical.Free; 89 | CoreLockCritical := nil; 90 | 91 | CoreComputeCritical.Free; 92 | CoreComputeCritical := nil; 93 | 94 | CoreTimeTickCritical.Free; 95 | CoreTimeTickCritical := nil; 96 | end; 97 | 98 | procedure GetCriticalLock(const Obj: TObject; var output: PCritical_Struct; var state: TGetCriticalLockState); 99 | var 100 | i, pIndex: Integer; 101 | p1, p2: PCritical_Struct; 102 | begin 103 | output := nil; 104 | pIndex := -1; 105 | p1 := nil; 106 | i := 0; 107 | while i < CriticalList.Count do 108 | begin 109 | p2 := PCritical_Struct(CriticalList[i]); 110 | if p2^.Obj = Obj then 111 | begin 112 | output := p2; 113 | state := TGetCriticalLockState.lsSame; 114 | exit; 115 | end 116 | else if (p2^.Obj = nil) and (p2^.LEnter = 0) then 117 | begin 118 | p1 := p2; 119 | pIndex := i; 120 | end; 121 | inc(i); 122 | end; 123 | 124 | if p1 <> nil then 125 | begin 126 | p1^.Obj := Obj; 127 | output := p1; 128 | if pIndex > 0 then 129 | CriticalList.Move(pIndex, 0); 130 | state := TGetCriticalLockState.lsIdle; 131 | end 132 | else 133 | begin 134 | new(p1); 135 | p1^.Obj := Obj; 136 | p1^.LEnter := 0; 137 | p1^.LockTick := GetTimeTick(); 138 | p1^.Critical := TCritical.Create; 139 | CriticalList.Insert(0, p1); 140 | output := p1; 141 | state := TGetCriticalLockState.lsNew; 142 | end; 143 | end; 144 | 145 | procedure _LockCriticalObj(Obj: TObject); 146 | var 147 | p: PCritical_Struct; 148 | ls: TGetCriticalLockState; 149 | begin 150 | CoreLockCritical.Acquire; 151 | GetCriticalLock(Obj, p, ls); 152 | CoreLockCritical.Release; 153 | p^.Critical.Acquire; 154 | p^.LockTick := GetTimeTick(); 155 | AtomInc(p^.LEnter); 156 | end; 157 | 158 | procedure _UnLockCriticalObj(Obj: TObject); 159 | var 160 | p: PCritical_Struct; 161 | ls: TGetCriticalLockState; 162 | begin 163 | CoreLockCritical.Acquire; 164 | GetCriticalLock(Obj, p, ls); 165 | CoreLockCritical.Release; 166 | 167 | AtomDec(p^.LEnter); 168 | if p^.LEnter < 0 then 169 | DoStatus('error: unlock failed: illegal unlock'); 170 | p^.LockTick := GetTimeTick(); 171 | p^.Critical.Release; 172 | end; 173 | 174 | procedure _RecycleLocker(const Obj: TObject); 175 | var 176 | p: PCritical_Struct; 177 | i: Integer; 178 | begin 179 | if (CoreLockCritical = nil) or (CriticalList = nil) or (CriticalList.Count = 0) then 180 | exit; 181 | 182 | CoreLockCritical.Acquire; 183 | i := 0; 184 | while i < CriticalList.Count do 185 | begin 186 | p := PCritical_Struct(CriticalList[i]); 187 | if p^.Obj = Obj then 188 | begin 189 | CriticalList.Delete(i); 190 | p^.Critical.Free; 191 | Dispose(p); 192 | break; 193 | end 194 | else 195 | inc(i); 196 | end; 197 | CoreLockCritical.Release; 198 | end; 199 | 200 | procedure AtomInc(var x: Int64); 201 | begin 202 | {$IFDEF FPC} 203 | CoreComputeCritical.Acquire; 204 | inc(x); 205 | CoreComputeCritical.Release; 206 | {$ELSE FPC} 207 | System.AtomicIncrement(x); 208 | {$ENDIF FPC} 209 | end; 210 | 211 | procedure AtomInc(var x: Int64; const v: Int64); 212 | begin 213 | {$IFDEF FPC} 214 | CoreComputeCritical.Acquire; 215 | inc(x, v); 216 | CoreComputeCritical.Release; 217 | {$ELSE FPC} 218 | System.AtomicIncrement(x, v); 219 | {$ENDIF FPC} 220 | end; 221 | 222 | procedure AtomDec(var x: Int64); 223 | begin 224 | {$IFDEF FPC} 225 | CoreComputeCritical.Acquire; 226 | dec(x); 227 | CoreComputeCritical.Release; 228 | {$ELSE FPC} 229 | System.AtomicDecrement(x); 230 | {$ENDIF FPC} 231 | end; 232 | 233 | procedure AtomDec(var x: Int64; const v: Int64); 234 | begin 235 | {$IFDEF FPC} 236 | CoreComputeCritical.Acquire; 237 | dec(x, v); 238 | CoreComputeCritical.Release; 239 | {$ELSE FPC} 240 | System.AtomicDecrement(x, v); 241 | {$ENDIF FPC} 242 | end; 243 | 244 | procedure AtomInc(var x: UInt64); 245 | begin 246 | {$IFDEF FPC} 247 | CoreComputeCritical.Acquire; 248 | inc(x); 249 | CoreComputeCritical.Release; 250 | {$ELSE FPC} 251 | System.AtomicIncrement(x); 252 | {$ENDIF FPC} 253 | end; 254 | 255 | procedure AtomInc(var x: UInt64; const v: UInt64); 256 | begin 257 | {$IFDEF FPC} 258 | CoreComputeCritical.Acquire; 259 | inc(x, v); 260 | CoreComputeCritical.Release; 261 | {$ELSE FPC} 262 | System.AtomicIncrement(x, v); 263 | {$ENDIF FPC} 264 | end; 265 | 266 | procedure AtomDec(var x: UInt64); 267 | begin 268 | {$IFDEF FPC} 269 | CoreComputeCritical.Acquire; 270 | dec(x); 271 | CoreComputeCritical.Release; 272 | {$ELSE FPC} 273 | System.AtomicDecrement(x); 274 | {$ENDIF FPC} 275 | end; 276 | 277 | procedure AtomDec(var x: UInt64; const v: UInt64); 278 | begin 279 | {$IFDEF FPC} 280 | CoreComputeCritical.Acquire; 281 | dec(x, v); 282 | CoreComputeCritical.Release; 283 | {$ELSE FPC} 284 | System.AtomicDecrement(x, v); 285 | {$ENDIF FPC} 286 | end; 287 | 288 | procedure AtomInc(var x: Integer); 289 | begin 290 | {$IFDEF FPC} 291 | CoreComputeCritical.Acquire; 292 | inc(x); 293 | CoreComputeCritical.Release; 294 | {$ELSE FPC} 295 | System.AtomicIncrement(x); 296 | {$ENDIF FPC} 297 | end; 298 | 299 | procedure AtomInc(var x: Integer; const v: Integer); 300 | begin 301 | {$IFDEF FPC} 302 | CoreComputeCritical.Acquire; 303 | inc(x, v); 304 | CoreComputeCritical.Release; 305 | {$ELSE FPC} 306 | System.AtomicIncrement(x, v); 307 | {$ENDIF FPC} 308 | end; 309 | 310 | procedure AtomDec(var x: Integer); 311 | begin 312 | {$IFDEF FPC} 313 | CoreComputeCritical.Acquire; 314 | dec(x); 315 | CoreComputeCritical.Release; 316 | {$ELSE FPC} 317 | System.AtomicDecrement(x); 318 | {$ENDIF FPC} 319 | end; 320 | 321 | procedure AtomDec(var x: Integer; const v: Integer); 322 | begin 323 | {$IFDEF FPC} 324 | CoreComputeCritical.Acquire; 325 | dec(x, v); 326 | CoreComputeCritical.Release; 327 | {$ELSE FPC} 328 | System.AtomicDecrement(x, v); 329 | {$ENDIF FPC} 330 | end; 331 | 332 | procedure AtomInc(var x: Cardinal); 333 | begin 334 | {$IFDEF FPC} 335 | CoreComputeCritical.Acquire; 336 | inc(x); 337 | CoreComputeCritical.Release; 338 | {$ELSE FPC} 339 | System.AtomicIncrement(x); 340 | {$ENDIF FPC} 341 | end; 342 | 343 | procedure AtomInc(var x: Cardinal; const v: Cardinal); 344 | begin 345 | {$IFDEF FPC} 346 | CoreComputeCritical.Acquire; 347 | inc(x, v); 348 | CoreComputeCritical.Release; 349 | {$ELSE FPC} 350 | System.AtomicIncrement(x, v); 351 | {$ENDIF FPC} 352 | end; 353 | 354 | procedure AtomDec(var x: Cardinal); 355 | begin 356 | {$IFDEF FPC} 357 | CoreComputeCritical.Acquire; 358 | dec(x); 359 | CoreComputeCritical.Release; 360 | {$ELSE FPC} 361 | System.AtomicDecrement(x); 362 | {$ENDIF FPC} 363 | end; 364 | 365 | procedure AtomDec(var x: Cardinal; const v: Cardinal); 366 | begin 367 | {$IFDEF FPC} 368 | CoreComputeCritical.Acquire; 369 | dec(x, v); 370 | CoreComputeCritical.Release; 371 | {$ELSE FPC} 372 | System.AtomicDecrement(x, v); 373 | {$ENDIF FPC} 374 | end; 375 | -------------------------------------------------------------------------------- /CoreClasses.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************************} 2 | {* Core class library written by QQ 600585@qq.com *} 3 | { * https://github.com/PassByYou888/CoreCipher * } 4 | { * https://github.com/PassByYou888/ZServer4D * } 5 | { * https://github.com/PassByYou888/zExpression * } 6 | { * https://github.com/PassByYou888/zTranslate * } 7 | { * https://github.com/PassByYou888/zSound * } 8 | { * https://github.com/PassByYou888/zAnalysis * } 9 | { ****************************************************************************** } 10 | 11 | (* 12 | update history 13 | 2017-12-6 14 | timetick 15 | *) 16 | 17 | unit CoreClasses; 18 | 19 | {$INCLUDE zDefine.inc} 20 | 21 | interface 22 | 23 | uses SysUtils, Classes, Types, 24 | {$IFDEF parallel} 25 | {$IFDEF FPC} 26 | mtprocs, 27 | {$ELSE FPC} 28 | Threading, 29 | {$ENDIF FPC} 30 | {$ENDIF parallel} 31 | PascalStrings, 32 | SyncObjs 33 | {$IFDEF FPC} 34 | , Contnrs, fgl, FPCGenericStructlist 35 | {$ELSE FPC} 36 | , System.Generics.Collections 37 | {$ENDIF FPC} 38 | ,Math; 39 | 40 | const 41 | fmCreate = Classes.fmCreate; 42 | soFromBeginning = Classes.soFromBeginning; 43 | soFromCurrent = Classes.soFromCurrent; 44 | soFromEnd = Classes.soFromEnd; 45 | 46 | fmOpenRead = SysUtils.fmOpenRead; 47 | fmOpenWrite = SysUtils.fmOpenWrite; 48 | fmOpenReadWrite = SysUtils.fmOpenReadWrite; 49 | 50 | fmShareExclusive = SysUtils.fmShareExclusive; 51 | fmShareDenyWrite = SysUtils.fmShareDenyWrite; 52 | fmShareDenyNone = SysUtils.fmShareDenyNone; 53 | 54 | type 55 | TBytes = SysUtils.TBytes; 56 | TPoint = Types.TPoint; 57 | 58 | TTimeTick = Int64; 59 | PTimeTick = ^TTimeTick; 60 | 61 | TSeekOrigin = Classes.TSeekOrigin; 62 | TNotify = Classes.TNotifyEvent; 63 | 64 | TCoreClassObject = TObject; 65 | TCoreClassPersistent = TPersistent; 66 | 67 | TCoreClassStream = TStream; 68 | TCoreClassFileStream = TFileStream; 69 | TCoreClassStringStream = TStringStream; 70 | TCoreClassResourceStream = TResourceStream; 71 | 72 | TCoreClassThread = TThread; 73 | 74 | CoreClassException = Exception; 75 | 76 | TCoreClassMemoryStream = TMemoryStream; 77 | TCoreClassStrings = TStrings; 78 | TCoreClassStringList = TStringList; 79 | TCoreClassReader = TReader; 80 | TCoreClassWriter = TWriter; 81 | TCoreClassComponent = TComponent; 82 | 83 | {$IFDEF FPC} 84 | PUInt64 = ^UInt64; 85 | 86 | TCoreClassInterfacedObject = class(TInterfacedObject) 87 | protected 88 | function _AddRef: longint; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF}; 89 | function _Release: longint; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF}; 90 | public 91 | procedure AfterConstruction; override; 92 | procedure BeforeDestruction; override; 93 | end; 94 | 95 | PCoreClassPointerList = Classes.PPointerList; 96 | TCoreClassPointerList = Classes.TPointerList; 97 | TCoreClassListSortCompare = Classes.TListSortCompare; 98 | TCoreClassListNotification = Classes.TListNotification; 99 | 100 | TCoreClassList = class(TList) 101 | property ListData: PPointerList read GetList; 102 | end; 103 | 104 | TCoreClassListForObj = class(TObjectList) 105 | public 106 | constructor Create; 107 | end; 108 | {$ELSE FPC} 109 | TCoreClassInterfacedObject = class(TInterfacedObject) 110 | protected 111 | function _AddRef: Integer; stdcall; 112 | function _Release: Integer; stdcall; 113 | public 114 | procedure AfterConstruction; override; 115 | procedure BeforeDestruction; override; 116 | end; 117 | 118 | TGenericsList=class(System.Generics.Collections.TList) 119 | private type 120 | TGArry = array of t; 121 | public var Arry:TGArry; 122 | function ListData: Pointer; 123 | end; 124 | 125 | TGenericsObjectList=class(System.Generics.Collections.TList) 126 | private type 127 | TGArry = array of t; 128 | public var Arry:TGArry; 129 | function ListData: Pointer; 130 | end; 131 | 132 | TCoreClassPointerList = array of Pointer; 133 | PCoreClassPointerList = ^TCoreClassPointerList; 134 | 135 | TCoreClassList = class(TGenericsList) 136 | function ListData: PCoreClassPointerList; 137 | end; 138 | 139 | TCoreClassForObjectList = array of TCoreClassObject; 140 | PCoreClassForObjectList = ^TCoreClassForObjectList; 141 | 142 | TCoreClassListForObj = class(TGenericsList) 143 | function ListData: PCoreClassForObjectList; 144 | end; 145 | {$ENDIF FPC} 146 | 147 | TComputeThread = class(TCoreClassThread) 148 | private type 149 | TRunWithThreadCall = procedure(Sender: TComputeThread); 150 | TRunWithThreadMethod = procedure(Sender: TComputeThread) of object; 151 | {$IFNDEF FPC} TRunWithThreadProc = reference to procedure(Sender: TComputeThread); {$ENDIF FPC} 152 | protected 153 | OnRunCall: TRunWithThreadCall; 154 | OnRunMethod: TRunWithThreadMethod; 155 | {$IFNDEF FPC} OnRunProc: TRunWithThreadProc; {$ENDIF FPC} 156 | OnDoneCall: TRunWithThreadCall; 157 | OnDoneMethod: TRunWithThreadMethod; 158 | {$IFNDEF FPC} OnDoneProc: TRunWithThreadProc; {$ENDIF FPC} 159 | procedure Execute; override; 160 | procedure Done_Sync; 161 | public 162 | UserData: Pointer; 163 | UserObject: TCoreClassObject; 164 | 165 | constructor Create; 166 | class function RunC(const Data: Pointer; const Obj: TCoreClassObject; const OnRun, OnDone: TRunWithThreadCall): TComputeThread; 167 | class function RunM(const Data: Pointer; const Obj: TCoreClassObject; const OnRun, OnDone: TRunWithThreadMethod): TComputeThread; 168 | {$IFNDEF FPC} class function RunP(const Data: Pointer; const Obj: TCoreClassObject; const OnRun, OnDone: TRunWithThreadProc): TComputeThread; {$ENDIF FPC} 169 | end; 170 | 171 | TSoftCritical = class(TCoreClassObject) 172 | private 173 | L: Boolean; 174 | public 175 | constructor Create; 176 | procedure Acquire; 177 | procedure Release; 178 | end; 179 | 180 | {$IFDEF SoftCritical} 181 | TCritical = TSoftCritical; 182 | {$ELSE SoftCritical} 183 | TCritical = TCriticalSection; 184 | {$ENDIF SoftCritical} 185 | 186 | TExecutePlatform = (epWin32, epWin64, epOSX32, epOSX64, epIOS, epIOSSIM, epANDROID32, epANDROID64, epLinux64, epLinux32, epUnknow); 187 | 188 | const 189 | {$IF Defined(WIN32)} 190 | CurrentPlatform = TExecutePlatform.epWin32; 191 | {$ELSEIF Defined(WIN64)} 192 | CurrentPlatform = TExecutePlatform.epWin64; 193 | {$ELSEIF Defined(OSX)} 194 | {$IFDEF CPU64} 195 | CurrentPlatform = TExecutePlatform.epOSX64; 196 | {$ELSE CPU64} 197 | CurrentPlatform = TExecutePlatform.epOSX32; 198 | {$IFEND CPU64} 199 | {$ELSEIF Defined(IOS)} 200 | {$IFDEF CPUARM} 201 | CurrentPlatform = TExecutePlatform.epIOS; 202 | {$ELSE CPUARM} 203 | CurrentPlatform = TExecutePlatform.epIOSSIM; 204 | {$ENDIF CPUARM} 205 | {$ELSEIF Defined(ANDROID)} 206 | {$IFDEF CPU64} 207 | CurrentPlatform = TExecutePlatform.epANDROID64; 208 | {$ELSE CPU64} 209 | CurrentPlatform = TExecutePlatform.epANDROID32; 210 | {$IFEND CPU64} 211 | {$ELSEIF Defined(Linux)} 212 | {$IFDEF CPU64} 213 | CurrentPlatform = TExecutePlatform.epLinux64; 214 | {$ELSE CPU64} 215 | CurrentPlatform = TExecutePlatform.epLinux32; 216 | {$IFEND CPU64} 217 | {$ELSE} 218 | CurrentPlatform = TExecutePlatform.epUnknow; 219 | {$IFEND} 220 | 221 | // NoP = No Operation. It's the empty function, whose purpose is only for the 222 | // debugging, or for the piece of code where intentionaly nothing is planned to be. 223 | procedure Nop; 224 | 225 | procedure CheckThreadSynchronize; overload; 226 | function CheckThreadSynchronize(Timeout: Integer): Boolean; overload; 227 | 228 | procedure DisposeObject(const Obj: TObject); overload; 229 | procedure DisposeObject(const objs: array of TObject); overload; 230 | procedure FreeObject(const Obj: TObject); overload; 231 | procedure FreeObject(const objs: array of TObject); overload; 232 | 233 | procedure LockID(const ID:Byte); 234 | procedure UnLockID(const ID:Byte); 235 | 236 | procedure LockObject(Obj:TObject); 237 | procedure UnLockObject(Obj:TObject); 238 | 239 | procedure AtomInc(var x: Int64); overload; 240 | procedure AtomInc(var x: Int64; const v: Int64); overload; 241 | procedure AtomDec(var x: Int64); overload; 242 | procedure AtomDec(var x: Int64; const v: Int64); overload; 243 | procedure AtomInc(var x: UInt64); overload; 244 | procedure AtomInc(var x: UInt64; const v: UInt64); overload; 245 | procedure AtomDec(var x: UInt64); overload; 246 | procedure AtomDec(var x: UInt64; const v: UInt64); overload; 247 | procedure AtomInc(var x: Integer); overload; 248 | procedure AtomInc(var x: Integer; const v:Integer); overload; 249 | procedure AtomDec(var x: Integer); overload; 250 | procedure AtomDec(var x: Integer; const v:Integer); overload; 251 | procedure AtomInc(var x: Cardinal); overload; 252 | procedure AtomInc(var x: Cardinal; const v:Cardinal); overload; 253 | procedure AtomDec(var x: Cardinal); overload; 254 | procedure AtomDec(var x: Cardinal; const v:Cardinal); overload; 255 | 256 | procedure FillPtrByte(const dest:Pointer; Count: NativeInt; const Value: Byte); inline; 257 | function CompareMemory(const p1, p2: Pointer; Count: NativeInt): Boolean; inline; 258 | procedure CopyPtr(const sour, dest:Pointer; Count: NativeInt); inline; 259 | 260 | procedure RaiseInfo(const n: SystemString); overload; 261 | procedure RaiseInfo(const n: SystemString; const Args: array of const); overload; 262 | 263 | function IsMobile: Boolean; 264 | 265 | function GetTimeTick: TTimeTick; 266 | function GetTimeTickCount: TTimeTick; 267 | function GetCrashTimeTick: TTimeTick; 268 | 269 | function ROL8(const Value: Byte; Shift: Byte): Byte; inline; 270 | function ROL16(const Value: Word; Shift: Byte): Word; inline; 271 | function ROL32(const Value: Cardinal; Shift: Byte): Cardinal; inline; 272 | function ROL64(const Value: UInt64; Shift: Byte): UInt64; inline; 273 | function ROR8(const Value: Byte; Shift: Byte): Byte; inline; 274 | function ROR16(const Value: Word; Shift: Byte): Word; inline; 275 | function ROR32(const Value: Cardinal; Shift: Byte): Cardinal; inline; 276 | function ROR64(const Value: UInt64; Shift: Byte): UInt64; inline; 277 | 278 | procedure Swap(var v1,v2:Byte); overload; 279 | procedure Swap(var v1,v2:Word); overload; 280 | procedure Swap(var v1,v2:Integer); overload; 281 | procedure Swap(var v1,v2:Int64); overload; 282 | procedure Swap(var v1,v2:UInt64); overload; 283 | procedure Swap(var v1,v2:SystemString); overload; 284 | procedure Swap(var v1,v2:Single); overload; 285 | procedure Swap(var v1,v2:Double); overload; 286 | procedure Swap(var v1,v2:Pointer); overload; 287 | 288 | function SAR16(const AValue: SmallInt; const Shift: Byte): SmallInt; 289 | function SAR32(const AValue: Integer; Shift: Byte): Integer; 290 | function SAR64(const AValue: Int64; Shift: Byte): Int64; 291 | 292 | function MemoryAlign(addr: Pointer; alignment: nativeUInt): Pointer; 293 | 294 | function Endian(const AValue: SmallInt): SmallInt; overload; 295 | function Endian(const AValue: Word): Word; overload; 296 | function Endian(const AValue: Integer): Integer; overload; 297 | function Endian(const AValue: Cardinal): Cardinal; overload; 298 | function Endian(const AValue: Int64): Int64; overload; 299 | function Endian(const AValue: UInt64): UInt64; overload; 300 | 301 | function BE2N(const AValue: SmallInt): SmallInt; overload; 302 | function BE2N(const AValue: Word): Word; overload; 303 | function BE2N(const AValue: Integer): Integer; overload; 304 | function BE2N(const AValue: Cardinal): Cardinal; overload; 305 | function BE2N(const AValue: Int64): Int64; overload; 306 | function BE2N(const AValue: UInt64): UInt64; overload; 307 | 308 | function LE2N(const AValue: SmallInt): SmallInt; overload; 309 | function LE2N(const AValue: Word): Word; overload; 310 | function LE2N(const AValue: Integer): Integer; overload; 311 | function LE2N(const AValue: Cardinal): Cardinal; overload; 312 | function LE2N(const AValue: Int64): Int64; overload; 313 | function LE2N(const AValue: UInt64): UInt64; overload; 314 | 315 | function N2BE(const AValue: SmallInt): SmallInt; overload; 316 | function N2BE(const AValue: Word): Word; overload; 317 | function N2BE(const AValue: Integer): Integer; overload; 318 | function N2BE(const AValue: Cardinal): Cardinal; overload; 319 | function N2BE(const AValue: Int64): Int64; overload; 320 | function N2BE(const AValue: UInt64): UInt64; overload; 321 | 322 | function N2LE(const AValue: SmallInt): SmallInt; overload; 323 | function N2LE(const AValue: Word): Word; overload; 324 | function N2LE(const AValue: Integer): Integer; overload; 325 | function N2LE(const AValue: Cardinal): Cardinal; overload; 326 | function N2LE(const AValue: Int64): Int64; overload; 327 | function N2LE(const AValue: UInt64): UInt64; overload; 328 | 329 | var 330 | GlobalMemoryHook: Boolean; 331 | 332 | implementation 333 | 334 | uses DoStatusIO; 335 | 336 | procedure Nop; 337 | begin 338 | end; 339 | 340 | var 341 | CheckThreadSynchronizeing: Boolean; 342 | 343 | procedure CheckThreadSynchronize; 344 | begin 345 | CheckThreadSynchronize(0); 346 | end; 347 | 348 | function CheckThreadSynchronize(Timeout: Integer): Boolean; 349 | begin 350 | DoStatus; 351 | if not CheckThreadSynchronizeing then 352 | begin 353 | CheckThreadSynchronizeing := True; 354 | try 355 | Result := CheckSynchronize(Timeout); 356 | finally 357 | CheckThreadSynchronizeing := False; 358 | end; 359 | end 360 | else 361 | Result := False; 362 | end; 363 | 364 | {$INCLUDE CoreAtomic.inc} 365 | 366 | procedure DisposeObject(const Obj: TObject); 367 | begin 368 | if Obj <> nil then 369 | begin 370 | try 371 | {$IFDEF AUTOREFCOUNT} 372 | Obj.DisposeOf; 373 | {$ELSE AUTOREFCOUNT} 374 | Obj.Free; 375 | {$ENDIF AUTOREFCOUNT} 376 | {$IFDEF CriticalSimulateAtomic} 377 | _RecycleLocker(Obj); 378 | {$ENDIF CriticalSimulateAtomic} 379 | except 380 | end; 381 | end; 382 | end; 383 | 384 | procedure DisposeObject(const objs: array of TObject); 385 | var 386 | Obj: TObject; 387 | begin 388 | for Obj in objs do 389 | DisposeObject(Obj); 390 | end; 391 | 392 | procedure FreeObject(const Obj: TObject); 393 | begin 394 | DisposeObject(Obj); 395 | end; 396 | 397 | procedure FreeObject(const objs: array of TObject); 398 | var 399 | Obj: TObject; 400 | begin 401 | for Obj in objs do 402 | FreeObject(Obj); 403 | end; 404 | 405 | var 406 | LockIDBuff: array [0..$FF] of TCoreClassPersistent; 407 | 408 | procedure InitLockIDBuff; 409 | var 410 | i: Byte; 411 | begin 412 | for i := 0 to $FF do 413 | LockIDBuff[i] := TCoreClassPersistent.Create; 414 | end; 415 | 416 | procedure FreeLockIDBuff; 417 | var 418 | i: Integer; 419 | begin 420 | for i := 0 to $FF do 421 | DisposeObject(LockIDBuff[i]); 422 | end; 423 | 424 | procedure LockID(const ID: Byte); 425 | begin 426 | LockObject(LockIDBuff[ID]); 427 | end; 428 | 429 | procedure UnLockID(const ID: Byte); 430 | begin 431 | UnLockObject(LockIDBuff[ID]); 432 | end; 433 | 434 | procedure LockObject(Obj:TObject); 435 | {$IFNDEF CriticalSimulateAtomic} 436 | {$IFDEF ANTI_DEAD_ATOMIC_LOCK} 437 | var 438 | d: TTimeTick; 439 | {$ENDIF ANTI_DEAD_ATOMIC_LOCK} 440 | {$ENDIF CriticalSimulateAtomic} 441 | begin 442 | {$IFDEF FPC} 443 | _LockCriticalObj(Obj); 444 | {$ELSE FPC} 445 | {$IFDEF CriticalSimulateAtomic} 446 | _LockCriticalObj(Obj); 447 | {$ELSE CriticalSimulateAtomic} 448 | {$IFDEF ANTI_DEAD_ATOMIC_LOCK} 449 | d := GetTimeTick; 450 | TMonitor.Enter(Obj, 5000); 451 | if GetTimeTick - d >= 5000 then 452 | RaiseInfo('dead lock'); 453 | {$ELSE ANTI_DEAD_ATOMIC_LOCK} 454 | TMonitor.Enter(Obj); 455 | {$ENDIF ANTI_DEAD_ATOMIC_LOCK} 456 | {$ENDIF CriticalSimulateAtomic} 457 | {$ENDIF FPC} 458 | end; 459 | 460 | procedure UnLockObject(Obj:TObject); 461 | begin 462 | {$IFDEF FPC} 463 | _UnLockCriticalObj(Obj); 464 | {$ELSE FPC} 465 | {$IFDEF CriticalSimulateAtomic} 466 | _UnLockCriticalObj(Obj); 467 | {$ELSE CriticalSimulateAtomic} 468 | TMonitor.Exit(Obj); 469 | {$ENDIF CriticalSimulateAtomic} 470 | {$ENDIF FPC} 471 | end; 472 | 473 | procedure FillPtrByte(const dest: Pointer; Count: NativeInt; const Value: Byte); 474 | var 475 | d: PByte; 476 | v: UInt64; 477 | begin 478 | if Count <= 0 then 479 | Exit; 480 | v := Value or (Value shl 8) or (Value shl 16) or (Value shl 24); 481 | v := v or (v shl 32); 482 | d := dest; 483 | while Count >= 8 do 484 | begin 485 | PUInt64(d)^ := v; 486 | dec(Count, 8); 487 | inc(d, 8); 488 | end; 489 | if Count >= 4 then 490 | begin 491 | PCardinal(d)^ := PCardinal(@v)^; 492 | dec(Count, 4); 493 | inc(d, 4); 494 | end; 495 | if Count >= 2 then 496 | begin 497 | PWORD(d)^ := PWORD(@v)^; 498 | dec(Count, 2); 499 | inc(d, 2); 500 | end; 501 | if Count > 0 then 502 | d^ := Value; 503 | end; 504 | 505 | function CompareMemory(const p1, p2: Pointer; Count: NativeInt): Boolean; 506 | var 507 | b1, b2: PByte; 508 | begin; 509 | if Count <= 0 then 510 | begin 511 | Result := True; 512 | Exit; 513 | end; 514 | Result := False; 515 | b1 := p1; 516 | b2 := p2; 517 | while (Count >= 8) do 518 | begin 519 | if PUInt64(b2)^ <> PUInt64(b1)^ then 520 | Exit; 521 | dec(Count, 8); 522 | inc(b2, 8); 523 | inc(b1, 8); 524 | end; 525 | if Count >= 4 then 526 | begin 527 | if PCardinal(b2)^ <> PCardinal(b1)^ then 528 | Exit; 529 | dec(Count, 4); 530 | inc(b2, 4); 531 | inc(b1, 4); 532 | end; 533 | if Count >= 2 then 534 | begin 535 | if PWORD(b2)^ <> PWORD(b1)^ then 536 | Exit; 537 | dec(Count, 2); 538 | inc(b2, 2); 539 | inc(b1, 2); 540 | end; 541 | if Count > 0 then 542 | if b2^ <> b1^ then 543 | Exit; 544 | Result := True; 545 | end; 546 | 547 | procedure CopyPtr(const sour, dest: Pointer; Count: NativeInt); 548 | var 549 | s, d: PByte; 550 | begin 551 | if Count <= 0 then 552 | Exit; 553 | s := sour; 554 | d := dest; 555 | while Count >= 8 do 556 | begin 557 | PUInt64(d)^ := PUInt64(s)^; 558 | dec(Count, 8); 559 | inc(d, 8); 560 | inc(s, 8); 561 | end; 562 | if Count >= 4 then 563 | begin 564 | PCardinal(d)^ := PCardinal(s)^; 565 | dec(Count, 4); 566 | inc(d, 4); 567 | inc(s, 4); 568 | end; 569 | if Count >= 2 then 570 | begin 571 | PWORD(d)^ := PWORD(s)^; 572 | dec(Count, 2); 573 | inc(d, 2); 574 | inc(s, 2); 575 | end; 576 | if Count > 0 then 577 | d^ := s^; 578 | end; 579 | 580 | procedure RaiseInfo(const n: SystemString); 581 | begin 582 | DoStatus('raise exception: ' + n); 583 | raise Exception.Create(n); 584 | end; 585 | 586 | procedure RaiseInfo(const n: SystemString; const Args: array of const); 587 | begin 588 | raise Exception.Create(Format(n, Args)); 589 | end; 590 | 591 | function IsMobile: Boolean; 592 | begin 593 | case CurrentPlatform of 594 | epIOS, epIOSSIM, epANDROID32, epANDROID64: Result := True; 595 | else Result := False; 596 | end; 597 | end; 598 | 599 | var 600 | Core_RunTime_Tick: TTimeTick; 601 | Core_Step_Tick: Cardinal; 602 | 603 | function GetTimeTick: TTimeTick; 604 | var 605 | tick: Cardinal; 606 | begin 607 | CoreTimeTickCritical.Acquire; 608 | try 609 | tick := TCoreClassThread.GetTickCount(); 610 | inc(Core_RunTime_Tick, tick - Core_Step_Tick); 611 | Core_Step_Tick := tick; 612 | Exit(Core_RunTime_Tick); 613 | finally 614 | CoreTimeTickCritical.Release; 615 | end; 616 | end; 617 | 618 | function GetTimeTickCount: TTimeTick; 619 | begin 620 | Result := GetTimeTick(); 621 | end; 622 | 623 | function GetCrashTimeTick: TTimeTick; 624 | begin 625 | Result := $FFFFFFFFFFFFFFFF - GetTimeTick(); 626 | end; 627 | 628 | {$IFDEF RangeCheck}{$R-}{$ENDIF} 629 | function ROL8(const Value: Byte; Shift: Byte): Byte; 630 | begin 631 | Shift := Shift and $07; 632 | Result := Byte((Value shl Shift) or (Value shr (8 - Shift))); 633 | end; 634 | 635 | function ROL16(const Value: Word; Shift: Byte): Word; 636 | begin 637 | Shift := Shift and $0F; 638 | Result := Word((Value shl Shift) or (Value shr (16 - Shift))); 639 | end; 640 | 641 | function ROL32(const Value: Cardinal; Shift: Byte): Cardinal; 642 | begin 643 | Shift := Shift and $1F; 644 | Result := Cardinal((Value shl Shift) or (Value shr (32 - Shift))); 645 | end; 646 | 647 | function ROL64(const Value: UInt64; Shift: Byte): UInt64; 648 | begin 649 | Shift := Shift and $3F; 650 | Result := UInt64((Value shl Shift) or (Value shr (64 - Shift))); 651 | end; 652 | 653 | function ROR8(const Value: Byte; Shift: Byte): Byte; 654 | begin 655 | Shift := Shift and $07; 656 | Result := UInt8((Value shr Shift) or (Value shl (8 - Shift))); 657 | end; 658 | 659 | function ROR16(const Value: Word; Shift: Byte): Word; 660 | begin 661 | Shift := Shift and $0F; 662 | Result := Word((Value shr Shift) or (Value shl (16 - Shift))); 663 | end; 664 | 665 | function ROR32(const Value: Cardinal; Shift: Byte): Cardinal; 666 | begin 667 | Shift := Shift and $1F; 668 | Result := Cardinal((Value shr Shift) or (Value shl (32 - Shift))); 669 | end; 670 | 671 | function ROR64(const Value: UInt64; Shift: Byte): UInt64; 672 | begin 673 | Shift := Shift and $3F; 674 | Result := UInt64((Value shr Shift) or (Value shl (64 - Shift))); 675 | end; 676 | {$IFDEF RangeCheck}{$R+}{$ENDIF} 677 | 678 | procedure Swap(var v1,v2: Byte); 679 | var 680 | v: Byte; 681 | begin 682 | v := v1; 683 | v1 := v2; 684 | v2 := v; 685 | end; 686 | 687 | procedure Swap(var v1,v2: Word); 688 | var 689 | v: Word; 690 | begin 691 | v := v1; 692 | v1 := v2; 693 | v2 := v; 694 | end; 695 | 696 | procedure Swap(var v1, v2: Integer); 697 | var 698 | v: Integer; 699 | begin 700 | v := v1; 701 | v1 := v2; 702 | v2 := v; 703 | end; 704 | 705 | procedure Swap(var v1, v2: Int64); 706 | var 707 | v: Int64; 708 | begin 709 | v := v1; 710 | v1 := v2; 711 | v2 := v; 712 | end; 713 | 714 | procedure Swap(var v1, v2: UInt64); 715 | var 716 | v: UInt64; 717 | begin 718 | v := v1; 719 | v1 := v2; 720 | v2 := v; 721 | end; 722 | 723 | procedure Swap(var v1, v2: SystemString); 724 | var 725 | v: SystemString; 726 | begin 727 | v := v1; 728 | v1 := v2; 729 | v2 := v; 730 | end; 731 | 732 | procedure Swap(var v1, v2: Single); 733 | var 734 | v: Single; 735 | begin 736 | v := v1; 737 | v1 := v2; 738 | v2 := v; 739 | end; 740 | 741 | procedure Swap(var v1, v2: Double); 742 | var 743 | v: Double; 744 | begin 745 | v := v1; 746 | v1 := v2; 747 | v2 := v; 748 | end; 749 | 750 | procedure Swap(var v1, v2: Pointer); 751 | var 752 | v: Pointer; 753 | begin 754 | v := v1; 755 | v1 := v2; 756 | v2 := v; 757 | end; 758 | 759 | {$IFDEF RangeCheck}{$R-}{$ENDIF} 760 | function SAR16(const AValue: SmallInt; const Shift: Byte): SmallInt; 761 | begin 762 | Result := SmallInt(Word(Word(Word(AValue) shr (Shift and 15)) or (Word(SmallInt(Word(0 - Word(Word(AValue) shr 15)) and Word(SmallInt(0 - (Ord((Shift and 15) <> 0) { and 1 } ))))) shl (16 - (Shift and 15))))); 763 | end; 764 | 765 | function SAR32(const AValue: Integer; Shift: Byte): Integer; 766 | begin 767 | Result := Integer(Cardinal(Cardinal(Cardinal(AValue) shr (Shift and 31)) or (Cardinal(Integer(Cardinal(0 - Cardinal(Cardinal(AValue) shr 31)) and Cardinal(Integer(0 - (Ord((Shift and 31) <> 0) { and 1 } ))))) shl (32 - (Shift and 31))))); 768 | end; 769 | 770 | function SAR64(const AValue: Int64; Shift: Byte): Int64; 771 | begin 772 | Result := Int64(UInt64(UInt64(UInt64(AValue) shr (Shift and 63)) or (UInt64(Int64(UInt64(0 - UInt64(UInt64(AValue) shr 63)) and UInt64(Int64(0 - (Ord((Shift and 63) <> 0) { and 1 } ))))) shl (64 - (Shift and 63))))); 773 | end; 774 | {$IFDEF RangeCheck}{$R+}{$ENDIF} 775 | 776 | function MemoryAlign(addr: Pointer; alignment: nativeUInt): Pointer; 777 | var 778 | tmp: nativeUInt; 779 | begin 780 | tmp := nativeUInt(addr) + (alignment - 1); 781 | Result := Pointer(tmp - (tmp mod alignment)); 782 | end; 783 | 784 | {$INCLUDE CoreEndian.inc} 785 | 786 | {$IFDEF FPC} 787 | 788 | 789 | function TCoreClassInterfacedObject._AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 790 | begin 791 | Result := 1; 792 | end; 793 | 794 | function TCoreClassInterfacedObject._Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 795 | begin 796 | Result := 1; 797 | end; 798 | 799 | procedure TCoreClassInterfacedObject.AfterConstruction; 800 | begin 801 | end; 802 | 803 | procedure TCoreClassInterfacedObject.BeforeDestruction; 804 | begin 805 | end; 806 | 807 | constructor TCoreClassListForObj.Create; 808 | begin 809 | inherited Create(False); 810 | end; 811 | 812 | {$ELSE} 813 | 814 | 815 | function TCoreClassInterfacedObject._AddRef: Integer; 816 | begin 817 | Result := 1; 818 | end; 819 | 820 | function TCoreClassInterfacedObject._Release: Integer; 821 | begin 822 | Result := 1; 823 | end; 824 | 825 | procedure TCoreClassInterfacedObject.AfterConstruction; 826 | begin 827 | end; 828 | 829 | procedure TCoreClassInterfacedObject.BeforeDestruction; 830 | begin 831 | end; 832 | 833 | function TGenericsList.ListData: Pointer; 834 | begin 835 | // set array pointer 836 | Arry := TGArry(Pointer(inherited List)); 837 | // @ array 838 | Result := @Arry; 839 | end; 840 | 841 | function TGenericsObjectList.ListData: Pointer; 842 | begin 843 | // set array pointer 844 | Arry := TGArry(Pointer(inherited List)); 845 | // @ array 846 | Result := @Arry; 847 | end; 848 | 849 | function TCoreClassList.ListData: PCoreClassPointerList; 850 | begin 851 | Result := PCoreClassPointerList(inherited ListData); 852 | end; 853 | 854 | function TCoreClassListForObj.ListData: PCoreClassForObjectList; 855 | begin 856 | Result := PCoreClassForObjectList(inherited ListData); 857 | end; 858 | 859 | {$ENDIF} 860 | 861 | 862 | 863 | procedure TComputeThread.Execute; 864 | begin 865 | try 866 | if Assigned(OnRunCall) then 867 | OnRunCall(Self); 868 | if Assigned(OnRunMethod) then 869 | OnRunMethod(Self); 870 | {$IFNDEF FPC} 871 | if Assigned(OnRunProc) then 872 | OnRunProc(Self); 873 | {$ENDIF FPC} 874 | except 875 | end; 876 | 877 | {$IFDEF FPC} 878 | Synchronize(@Done_Sync); 879 | {$ELSE FPC} 880 | Synchronize(Done_Sync); 881 | {$ENDIF FPC} 882 | end; 883 | 884 | procedure TComputeThread.Done_Sync; 885 | begin 886 | try 887 | if Assigned(OnDoneCall) then 888 | OnDoneCall(Self); 889 | if Assigned(OnDoneMethod) then 890 | OnDoneMethod(Self); 891 | {$IFNDEF FPC} 892 | if Assigned(OnDoneProc) then 893 | OnDoneProc(Self); 894 | {$ENDIF FPC} 895 | except 896 | end; 897 | end; 898 | 899 | constructor TComputeThread.Create; 900 | begin 901 | inherited Create(True); 902 | FreeOnTerminate := True; 903 | 904 | OnRunCall := nil; 905 | OnRunMethod := nil; 906 | {$IFNDEF FPC} OnRunProc := nil; {$ENDIF FPC} 907 | OnDoneCall := nil; 908 | OnDoneMethod := nil; 909 | {$IFNDEF FPC} OnDoneProc := nil; {$ENDIF FPC} 910 | UserData := nil; 911 | UserObject := nil; 912 | end; 913 | 914 | class function TComputeThread.RunC(const Data: Pointer; const Obj: TCoreClassObject; const OnRun, OnDone: TRunWithThreadCall): TComputeThread; 915 | begin 916 | Result := TComputeThread.Create; 917 | Result.FreeOnTerminate := True; 918 | 919 | Result.OnRunCall := OnRun; 920 | Result.OnDoneCall := OnDone; 921 | Result.UserData := Data; 922 | Result.UserObject := Obj; 923 | Result.Suspended := False; 924 | end; 925 | 926 | class function TComputeThread.RunM(const Data: Pointer; const Obj: TCoreClassObject; const OnRun, OnDone: TRunWithThreadMethod): TComputeThread; 927 | begin 928 | Result := TComputeThread.Create; 929 | Result.FreeOnTerminate := True; 930 | 931 | Result.OnRunMethod := OnRun; 932 | Result.OnDoneMethod := OnDone; 933 | Result.UserData := Data; 934 | Result.UserObject := Obj; 935 | Result.Suspended := False; 936 | end; 937 | 938 | {$IFNDEF FPC} 939 | 940 | 941 | class function TComputeThread.RunP(const Data: Pointer; const Obj: TCoreClassObject; const OnRun, OnDone: TRunWithThreadProc): TComputeThread; 942 | begin 943 | Result := TComputeThread.Create; 944 | Result.FreeOnTerminate := True; 945 | 946 | Result.OnRunProc := OnRun; 947 | Result.OnDoneProc := OnDone; 948 | Result.UserData := Data; 949 | Result.UserObject := Obj; 950 | Result.Suspended := False; 951 | end; 952 | {$ENDIF FPC} 953 | 954 | 955 | initialization 956 | Core_RunTime_Tick := 1000 * 60 * 60 * 24 * 3; 957 | Core_Step_Tick := TCoreClassThread.GetTickCount(); 958 | InitCriticalLock; 959 | InitLockIDBuff; 960 | GlobalMemoryHook := True; 961 | CheckThreadSynchronizeing := False; 962 | 963 | // float check 964 | SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, exOverflow, exUnderflow, exPrecision]); 965 | finalization 966 | FreeCriticalLock; 967 | FreeLockIDBuff; 968 | GlobalMemoryHook := False; 969 | end. 970 | 971 | -------------------------------------------------------------------------------- /CoreEndian.inc: -------------------------------------------------------------------------------- 1 | {$IFDEF OverflowCheck}{$Q-}{$ENDIF} 2 | {$IFDEF RangeCheck}{$R-}{$ENDIF} 3 | 4 | 5 | function Endian(const AValue: SmallInt): SmallInt; 6 | begin 7 | { the extra Word type cast is necessary because the "AValue shr 8" } 8 | { is turned into "Integer(AValue) shr 8", so if AValue < 0 then } 9 | { the sign bits from the upper 16 bits are shifted in rather than } 10 | { zeroes. } 11 | Result := SmallInt((Word(AValue) shr 8) or (Word(AValue) shl 8)); 12 | end; 13 | 14 | function Endian(const AValue: Word): Word; 15 | begin 16 | Result := Word((AValue shr 8) or (AValue shl 8)); 17 | end; 18 | 19 | function Endian(const AValue: Integer): Integer; 20 | begin 21 | Result := ((Cardinal(AValue) shl 8) and $FF00FF00) or ((Cardinal(AValue) shr 8) and $00FF00FF); 22 | Result := (Cardinal(Result) shl 16) or (Cardinal(Result) shr 16); 23 | end; 24 | 25 | function Endian(const AValue: Cardinal): Cardinal; 26 | begin 27 | Result := ((AValue shl 8) and $FF00FF00) or ((AValue shr 8) and $00FF00FF); 28 | Result := (Result shl 16) or (Result shr 16); 29 | end; 30 | 31 | function Endian(const AValue: Int64): Int64; 32 | begin 33 | Result := ((UInt64(AValue) shl 8) and $FF00FF00FF00FF00) or ((UInt64(AValue) shr 8) and $00FF00FF00FF00FF); 34 | Result := ((UInt64(Result) shl 16) and $FFFF0000FFFF0000) or ((UInt64(Result) shr 16) and $0000FFFF0000FFFF); 35 | Result := (UInt64(Result) shl 32) or ((UInt64(Result) shr 32)); 36 | end; 37 | 38 | function Endian(const AValue: UInt64): UInt64; 39 | begin 40 | Result := ((AValue shl 8) and $FF00FF00FF00FF00) or ((AValue shr 8) and $00FF00FF00FF00FF); 41 | Result := ((Result shl 16) and $FFFF0000FFFF0000) or ((Result shr 16) and $0000FFFF0000FFFF); 42 | Result := (Result shl 32) or ((Result shr 32)); 43 | end; 44 | 45 | function BE2N(const AValue: SmallInt): SmallInt; 46 | begin 47 | {$IFDEF BIG_ENDIAN} 48 | Result := AValue; 49 | {$ELSE} 50 | Result := Endian(AValue); 51 | {$ENDIF} 52 | end; 53 | 54 | function BE2N(const AValue: Word): Word; 55 | begin 56 | {$IFDEF BIG_ENDIAN} 57 | Result := AValue; 58 | {$ELSE} 59 | Result := Endian(AValue); 60 | {$ENDIF} 61 | end; 62 | 63 | function BE2N(const AValue: Integer): Integer; 64 | begin 65 | {$IFDEF BIG_ENDIAN} 66 | Result := AValue; 67 | {$ELSE} 68 | Result := Endian(AValue); 69 | {$ENDIF} 70 | end; 71 | 72 | function BE2N(const AValue: Cardinal): Cardinal; 73 | begin 74 | {$IFDEF BIG_ENDIAN} 75 | Result := AValue; 76 | {$ELSE} 77 | Result := Endian(AValue); 78 | {$ENDIF} 79 | end; 80 | 81 | function BE2N(const AValue: Int64): Int64; 82 | begin 83 | {$IFDEF BIG_ENDIAN} 84 | Result := AValue; 85 | {$ELSE} 86 | Result := Endian(AValue); 87 | {$ENDIF} 88 | end; 89 | 90 | function BE2N(const AValue: UInt64): UInt64; 91 | begin 92 | {$IFDEF BIG_ENDIAN} 93 | Result := AValue; 94 | {$ELSE} 95 | Result := Endian(AValue); 96 | {$ENDIF} 97 | end; 98 | 99 | function LE2N(const AValue: SmallInt): SmallInt; 100 | begin 101 | {$IFDEF LITTLE_ENDIAN} 102 | Result := AValue; 103 | {$ELSE} 104 | Result := Endian(AValue); 105 | {$ENDIF} 106 | end; 107 | 108 | function LE2N(const AValue: Word): Word; 109 | begin 110 | {$IFDEF LITTLE_ENDIAN} 111 | Result := AValue; 112 | {$ELSE} 113 | Result := Endian(AValue); 114 | {$ENDIF} 115 | end; 116 | 117 | function LE2N(const AValue: Integer): Integer; 118 | begin 119 | {$IFDEF LITTLE_ENDIAN} 120 | Result := AValue; 121 | {$ELSE} 122 | Result := Endian(AValue); 123 | {$ENDIF} 124 | end; 125 | 126 | function LE2N(const AValue: Cardinal): Cardinal; 127 | begin 128 | {$IFDEF LITTLE_ENDIAN} 129 | Result := AValue; 130 | {$ELSE} 131 | Result := Endian(AValue); 132 | {$ENDIF} 133 | end; 134 | 135 | function LE2N(const AValue: Int64): Int64; 136 | begin 137 | {$IFDEF LITTLE_ENDIAN} 138 | Result := AValue; 139 | {$ELSE} 140 | Result := Endian(AValue); 141 | {$ENDIF} 142 | end; 143 | 144 | function LE2N(const AValue: UInt64): UInt64; 145 | begin 146 | {$IFDEF LITTLE_ENDIAN} 147 | Result := AValue; 148 | {$ELSE} 149 | Result := Endian(AValue); 150 | {$ENDIF} 151 | end; 152 | 153 | function N2BE(const AValue: SmallInt): SmallInt; 154 | begin 155 | {$IFDEF BIG_ENDIAN} 156 | Result := AValue; 157 | {$ELSE} 158 | Result := Endian(AValue); 159 | {$ENDIF} 160 | end; 161 | 162 | function N2BE(const AValue: Word): Word; 163 | begin 164 | {$IFDEF BIG_ENDIAN} 165 | Result := AValue; 166 | {$ELSE} 167 | Result := Endian(AValue); 168 | {$ENDIF} 169 | end; 170 | 171 | function N2BE(const AValue: Integer): Integer; 172 | begin 173 | {$IFDEF BIG_ENDIAN} 174 | Result := AValue; 175 | {$ELSE} 176 | Result := Endian(AValue); 177 | {$ENDIF} 178 | end; 179 | 180 | function N2BE(const AValue: Cardinal): Cardinal; 181 | begin 182 | {$IFDEF BIG_ENDIAN} 183 | Result := AValue; 184 | {$ELSE} 185 | Result := Endian(AValue); 186 | {$ENDIF} 187 | end; 188 | 189 | function N2BE(const AValue: Int64): Int64; 190 | begin 191 | {$IFDEF BIG_ENDIAN} 192 | Result := AValue; 193 | {$ELSE} 194 | Result := Endian(AValue); 195 | {$ENDIF} 196 | end; 197 | 198 | function N2BE(const AValue: UInt64): UInt64; 199 | begin 200 | {$IFDEF BIG_ENDIAN} 201 | Result := AValue; 202 | {$ELSE} 203 | Result := Endian(AValue); 204 | {$ENDIF} 205 | end; 206 | 207 | function N2LE(const AValue: SmallInt): SmallInt; 208 | begin 209 | {$IFDEF LITTLE_ENDIAN} 210 | Result := AValue; 211 | {$ELSE} 212 | Result := Endian(AValue); 213 | {$ENDIF} 214 | end; 215 | 216 | function N2LE(const AValue: Word): Word; 217 | begin 218 | {$IFDEF LITTLE_ENDIAN} 219 | Result := AValue; 220 | {$ELSE} 221 | Result := Endian(AValue); 222 | {$ENDIF} 223 | end; 224 | 225 | function N2LE(const AValue: Integer): Integer; 226 | begin 227 | {$IFDEF LITTLE_ENDIAN} 228 | Result := AValue; 229 | {$ELSE} 230 | Result := Endian(AValue); 231 | {$ENDIF} 232 | end; 233 | 234 | function N2LE(const AValue: Cardinal): Cardinal; 235 | begin 236 | {$IFDEF LITTLE_ENDIAN} 237 | Result := AValue; 238 | {$ELSE} 239 | Result := Endian(AValue); 240 | {$ENDIF} 241 | end; 242 | 243 | function N2LE(const AValue: Int64): Int64; 244 | begin 245 | {$IFDEF LITTLE_ENDIAN} 246 | Result := AValue; 247 | {$ELSE} 248 | Result := Endian(AValue); 249 | {$ENDIF} 250 | end; 251 | 252 | function N2LE(const AValue: UInt64): UInt64; 253 | begin 254 | {$IFDEF LITTLE_ENDIAN} 255 | Result := AValue; 256 | {$ELSE} 257 | Result := Endian(AValue); 258 | {$ENDIF} 259 | end; 260 | 261 | {$IFDEF OverflowCheck}{$Q+}{$ENDIF} 262 | {$IFDEF RangeCheck}{$R+}{$ENDIF} 263 | -------------------------------------------------------------------------------- /PascalStrings.pas: -------------------------------------------------------------------------------- 1 | { ***************************************************************************** } 2 | { * string support,writen by QQ 600585@qq.com * } 3 | { * https://github.com/PassByYou888/CoreCipher * } 4 | { * https://github.com/PassByYou888/ZServer4D * } 5 | { * https://github.com/PassByYou888/zExpression * } 6 | { * https://github.com/PassByYou888/zTranslate * } 7 | { * https://github.com/PassByYou888/zSound * } 8 | { * https://github.com/PassByYou888/zAnalysis * } 9 | { * https://github.com/PassByYou888/zGameWare * } 10 | { * https://github.com/PassByYou888/zRasterization * } 11 | { ****************************************************************************** } 12 | 13 | (* 14 | update history 15 | 2017-11-26 16 | fixed UnicodeString in FPC 17 | *) 18 | 19 | unit PascalStrings; 20 | 21 | {$INCLUDE zDefine.inc} 22 | 23 | interface 24 | 25 | uses SysUtils; 26 | 27 | type 28 | SystemChar = Char; 29 | SystemString = string; 30 | THash = Cardinal; 31 | THash64 = UInt64; 32 | PSystemString = ^SystemString; 33 | PPascalString = ^TPascalString; 34 | TArrayChar = array of SystemChar; 35 | TOrdChar = (c0to9, c1to9, c0to32, c0to32no10, cLoAtoF, cHiAtoF, cLoAtoZ, cHiAtoZ, cHex, cAtoF, cAtoZ); 36 | TOrdChars = set of TOrdChar; 37 | 38 | TPascalString = record 39 | private 40 | function GetText: SystemString; 41 | procedure SetText(const Value: SystemString); 42 | function GetLen: Integer; 43 | procedure SetLen(const Value: Integer); 44 | function GetChars(index: Integer): SystemChar; 45 | procedure SetChars(index: Integer; const Value: SystemChar); 46 | function GetBytes: TBytes; 47 | procedure SetBytes(const Value: TBytes); 48 | function GetLast: SystemChar; 49 | procedure SetLast(const Value: SystemChar); 50 | function GetFirst: SystemChar; 51 | procedure SetFirst(const Value: SystemChar); 52 | public 53 | buff: TArrayChar; 54 | 55 | {$IFDEF DELPHI} 56 | class operator Equal(const Lhs, Rhs: TPascalString): Boolean; 57 | class operator NotEqual(const Lhs, Rhs: TPascalString): Boolean; 58 | class operator GreaterThan(const Lhs, Rhs: TPascalString): Boolean; 59 | class operator GreaterThanOrEqual(const Lhs, Rhs: TPascalString): Boolean; 60 | class operator LessThan(const Lhs, Rhs: TPascalString): Boolean; 61 | class operator LessThanOrEqual(const Lhs, Rhs: TPascalString): Boolean; 62 | 63 | class operator Add(const Lhs, Rhs: TPascalString): TPascalString; 64 | class operator Add(const Lhs: SystemString; const Rhs: TPascalString): TPascalString; 65 | class operator Add(const Lhs: TPascalString; const Rhs: SystemString): TPascalString; 66 | class operator Add(const Lhs: SystemChar; const Rhs: TPascalString): TPascalString; 67 | class operator Add(const Lhs: TPascalString; const Rhs: SystemChar): TPascalString; 68 | 69 | class operator Implicit(Value: Variant): TPascalString; 70 | class operator Implicit(Value: SystemString): TPascalString; 71 | class operator Implicit(Value: SystemChar): TPascalString; 72 | class operator Implicit(Value: TPascalString): SystemString; 73 | class operator Implicit(Value: TPascalString): Variant; 74 | 75 | class operator Explicit(Value: TPascalString): SystemString; 76 | class operator Explicit(Value: SystemString): TPascalString; 77 | class operator Explicit(Value: SystemChar): TPascalString; 78 | class operator Explicit(Value: Variant): TPascalString; 79 | class operator Explicit(Value: TPascalString): Variant; 80 | {$ENDIF} 81 | function Copy(index, Count: NativeInt): TPascalString; 82 | function Same(const p: PPascalString): Boolean; overload; 83 | function Same(const t: TPascalString): Boolean; overload; 84 | function Same(const t1, t2: TPascalString): Boolean; overload; 85 | function Same(const t1, t2, t3: TPascalString): Boolean; overload; 86 | function Same(const t1, t2, t3, t4: TPascalString): Boolean; overload; 87 | function Same(const t1, t2, t3, t4, t5: TPascalString): Boolean; overload; 88 | function Same(const IgnoreCase: Boolean; const t: TPascalString): Boolean; overload; 89 | function ComparePos(const Offset: Integer; const p: PPascalString): Boolean; overload; 90 | function ComparePos(const Offset: Integer; const t: TPascalString): Boolean; overload; 91 | function GetPos(const s: TPascalString; const Offset: Integer = 1): Integer; overload; 92 | function GetPos(const s: PPascalString; const Offset: Integer = 1): Integer; overload; 93 | function Exists(c: SystemChar): Boolean; overload; 94 | function Exists(c: array of SystemChar): Boolean; overload; 95 | function Exists(const s: TPascalString): Boolean; overload; 96 | function GetCharCount(c: SystemChar): Integer; 97 | // 98 | function hash: THash; 99 | function Hash64: THash64; 100 | // 101 | property Last: SystemChar read GetLast write SetLast; 102 | property First: SystemChar read GetFirst write SetFirst; 103 | 104 | procedure DeleteLast; 105 | procedure DeleteFirst; 106 | procedure Delete(idx, cnt: Integer); 107 | procedure Clear; 108 | procedure Append(t: TPascalString); overload; 109 | procedure Append(c: SystemChar); overload; 110 | function GetString(bPos, ePos: NativeInt): TPascalString; 111 | procedure Insert(AText: SystemString; idx: Integer); 112 | // 113 | procedure FastAsText(var output: SystemString); 114 | procedure FastGetBytes(var output: TBytes); 115 | // 116 | property Text: SystemString read GetText write SetText; 117 | function LowerText: SystemString; 118 | function UpperText: SystemString; 119 | function Invert: TPascalString; 120 | function TrimChar(const Chars: TPascalString): TPascalString; 121 | function DeleteChar(const Chars: TPascalString): TPascalString; overload; 122 | function DeleteChar(const Chars: TOrdChars): TPascalString; overload; 123 | function ReplaceChar(const Chars: TPascalString; const newChar: SystemChar): TPascalString; overload; 124 | function ReplaceChar(const Chars, newChar: SystemChar): TPascalString; overload; 125 | function ReplaceChar(const Chars: TOrdChars; const newChar: SystemChar): TPascalString; overload; 126 | 127 | { https://en.wikipedia.org/wiki/Smith%E2%80%93Waterman_algorithm } 128 | function SmithWaterman(const p: PPascalString): Double; overload; 129 | function SmithWaterman(const s: TPascalString): Double; overload; 130 | 131 | property Len: Integer read GetLen write SetLen; 132 | property Chars[index: Integer]: SystemChar read GetChars write SetChars; default; 133 | property Bytes: TBytes read GetBytes write SetBytes; 134 | function BOMBytes: TBytes; 135 | end; 136 | 137 | TArrayPascalString = array of TPascalString; 138 | PArrayPascalString = ^TArrayPascalString; 139 | 140 | TArrayPascalStringPtr = array of PPascalString; 141 | PArrayPascalStringPtr = ^TArrayPascalStringPtr; 142 | 143 | function CharIn(c: SystemChar; const SomeChars: array of SystemChar): Boolean; overload; 144 | function CharIn(c: SystemChar; const SomeChar: SystemChar): Boolean; overload; 145 | function CharIn(c: SystemChar; const s: TPascalString): Boolean; overload; 146 | function CharIn(c: SystemChar; const p: PPascalString): Boolean; overload; 147 | function CharIn(c: SystemChar; const SomeCharsets: TOrdChars): Boolean; overload; 148 | function CharIn(c: SystemChar; const SomeCharset: TOrdChar): Boolean; overload; 149 | function CharIn(c: SystemChar; const SomeCharsets: TOrdChars; const SomeChars: TPascalString): Boolean; overload; 150 | function CharIn(c: SystemChar; const SomeCharsets: TOrdChars; const p: PPascalString): Boolean; overload; 151 | 152 | function FastHashPSystemString(const s: PSystemString): THash; overload; 153 | function FastHash64PSystemString(const s: PSystemString): THash64; overload; 154 | 155 | function FastHashSystemString(const s: SystemString): THash; overload; 156 | function FastHash64SystemString(const s: SystemString): THash64; overload; 157 | 158 | function FastHashPPascalString(const s: PPascalString): THash; 159 | function FastHash64PPascalString(const s: PPascalString): THash64; 160 | 161 | function PFormat(const Fmt: SystemString; const Args: array of const): SystemString; 162 | 163 | {$IFDEF FPC} 164 | 165 | operator := (const s: Variant)r: TPascalString; 166 | operator := (const s: AnsiString)r: TPascalString; 167 | operator := (const s: UnicodeString)r: TPascalString; 168 | operator := (const s: WideString)r: TPascalString; 169 | operator := (const s: ShortString)r: TPascalString; 170 | operator := (const c: SystemChar)r: TPascalString; 171 | 172 | operator := (const s: TPascalString)r: AnsiString; 173 | operator := (const s: TPascalString)r: UnicodeString; 174 | operator := (const s: TPascalString)r: WideString; 175 | operator := (const s: TPascalString)r: ShortString; 176 | operator := (const s: TPascalString)r: Variant; 177 | 178 | operator = (const a: TPascalString; const b: TPascalString): Boolean; 179 | operator <> (const a: TPascalString; const b: TPascalString): Boolean; 180 | operator > (const a: TPascalString; const b: TPascalString): Boolean; 181 | operator >= (const a: TPascalString; const b: TPascalString): Boolean; 182 | operator < (const a: TPascalString; const b: TPascalString): Boolean; 183 | operator <= (const a: TPascalString; const b: TPascalString): Boolean; 184 | 185 | operator + (const a: TPascalString; const b: TPascalString): TPascalString; 186 | operator + (const a: TPascalString; const b: SystemString): TPascalString; 187 | operator + (const a: SystemString; const b: TPascalString): TPascalString; 188 | operator + (const a: TPascalString; const b: SystemChar): TPascalString; 189 | operator + (const a: SystemChar; const b: TPascalString): TPascalString; 190 | 191 | {$ENDIF FPC} 192 | 193 | { https://en.wikipedia.org/wiki/Smith%E2%80%93Waterman_algorithm } 194 | 195 | // short string likeness and out diff 196 | function SmithWatermanCompare(const seq1, seq2: PPascalString; var diff1, diff2: TPascalString; 197 | const NoDiffChar: Boolean; const diffChar: SystemChar): Double; overload; 198 | function SmithWatermanCompare(const seq1, seq2: PPascalString; var diff1, diff2: TPascalString): Double; overload; 199 | function SmithWatermanCompare(const seq1, seq2: TPascalString; var diff1, diff2: TPascalString; 200 | const NoDiffChar: Boolean; const diffChar: SystemChar): Double; overload; 201 | function SmithWatermanCompare(const seq1, seq2: TPascalString; var diff1, diff2: TPascalString): Double; overload; 202 | 203 | // short string likeness 204 | function SmithWatermanCompare(const seq1, seq2: PPascalString; out Same, Diff: Integer): Double; overload; 205 | function SmithWatermanCompare(const seq1, seq2: PPascalString): Double; overload; 206 | function SmithWatermanCompare(const seq1, seq2: TPascalString): Double; overload; 207 | function SmithWatermanCompare(const seq1: TArrayPascalString; const seq2: TPascalString): Double; overload; 208 | 209 | // memory likeness 210 | function SmithWatermanCompare(const seq1: Pointer; siz1: Integer; const seq2: Pointer; siz2: Integer; 211 | out Same, Diff: Integer): Double; overload; 212 | function SmithWatermanCompare(const seq1: Pointer; siz1: Integer; const seq2: Pointer; siz2: Integer): Double; overload; 213 | 214 | // long string likeness 215 | function SmithWatermanCompareLongString(const t1, t2: TPascalString; const MinDiffCharWithPeerLine: Integer; out Same, Diff: Integer): Double; overload; 216 | function SmithWatermanCompareLongString(const t1, t2: TPascalString): Double; overload; 217 | 218 | var 219 | SystemCharSize: NativeInt = SizeOf(SystemChar); 220 | {$IFDEF CPU64} 221 | MaxSmithWatermanMatrix: NativeInt = 10000 * 10; 222 | {$ELSE} 223 | MaxSmithWatermanMatrix: NativeInt = 8192; 224 | {$ENDIF} 225 | 226 | 227 | const 228 | {$IFDEF FirstCharInZero} 229 | FirstCharPos = 0; 230 | {$ELSE} 231 | FirstCharPos = 1; 232 | {$ENDIF} 233 | 234 | implementation 235 | 236 | uses CoreClasses, Variants; 237 | 238 | procedure CombineCharsPP(const c1, c2: TArrayChar; var output: TArrayChar); 239 | var 240 | LL, rl: Integer; 241 | begin 242 | LL := length(c1); 243 | rl := length(c2); 244 | SetLength(output, LL + rl); 245 | if LL > 0 then 246 | CopyPtr(@c1[0], @output[0], LL * SystemCharSize); 247 | if rl > 0 then 248 | CopyPtr(@c2[0], @output[LL], rl * SystemCharSize); 249 | end; 250 | 251 | procedure CombineCharsSP(const c1: SystemString; const c2: TArrayChar; var output: TArrayChar); 252 | var 253 | LL, rl: Integer; 254 | begin 255 | LL := length(c1); 256 | rl := length(c2); 257 | SetLength(output, LL + rl); 258 | if LL > 0 then 259 | CopyPtr(@c1[FirstCharPos], @output[0], LL * SystemCharSize); 260 | if rl > 0 then 261 | CopyPtr(@c2[0], @output[LL], rl * SystemCharSize); 262 | end; 263 | 264 | procedure CombineCharsPS(const c1: TArrayChar; const c2: SystemString; var output: TArrayChar); 265 | var 266 | LL, rl: Integer; 267 | begin 268 | LL := length(c1); 269 | rl := length(c2); 270 | SetLength(output, LL + rl); 271 | if LL > 0 then 272 | CopyPtr(@c1[0], @output[0], LL * SystemCharSize); 273 | if rl > 0 then 274 | CopyPtr(@c2[FirstCharPos], @output[LL], rl * SystemCharSize); 275 | end; 276 | 277 | procedure CombineCharsCP(const c1: SystemChar; const c2: TArrayChar; var output: TArrayChar); 278 | var 279 | rl: Integer; 280 | begin 281 | rl := length(c2); 282 | SetLength(output, rl + 1); 283 | output[0] := c1; 284 | if rl > 0 then 285 | CopyPtr(@c2[0], @output[1], rl * SystemCharSize); 286 | end; 287 | 288 | procedure CombineCharsPC(const c1: TArrayChar; const c2: SystemChar; var output: TArrayChar); 289 | var 290 | LL: Integer; 291 | begin 292 | LL := length(c1); 293 | SetLength(output, LL + 1); 294 | if LL > 0 then 295 | CopyPtr(@c1[0], @output[0], LL * SystemCharSize); 296 | output[LL] := c2; 297 | end; 298 | 299 | function CharIn(c: SystemChar; const SomeChars: array of SystemChar): Boolean; 300 | var 301 | AChar: SystemChar; 302 | begin 303 | Result := True; 304 | for AChar in SomeChars do 305 | if AChar = c then 306 | Exit; 307 | Result := False; 308 | end; 309 | 310 | function CharIn(c: SystemChar; const SomeChar: SystemChar): Boolean; 311 | begin 312 | Result := c = SomeChar; 313 | end; 314 | 315 | function CharIn(c: SystemChar; const s: TPascalString): Boolean; 316 | begin 317 | Result := s.Exists(c); 318 | end; 319 | 320 | function CharIn(c: SystemChar; const p: PPascalString): Boolean; 321 | begin 322 | Result := p^.Exists(c); 323 | end; 324 | 325 | function CharIn(c: SystemChar; const SomeCharset: TOrdChar): Boolean; 326 | const 327 | ord0 = Ord('0'); 328 | ord1 = Ord('1'); 329 | ord9 = Ord('9'); 330 | ordLA = Ord('a'); 331 | ordHA = Ord('A'); 332 | ordLF = Ord('f'); 333 | ordHF = Ord('F'); 334 | ordLZ = Ord('z'); 335 | ordHZ = Ord('Z'); 336 | 337 | var 338 | v: Word; 339 | begin 340 | v := Ord(c); 341 | case SomeCharset of 342 | c0to9: Result := (v >= ord0) and (v <= ord9); 343 | c1to9: Result := (v >= ord1) and (v <= ord9); 344 | c0to32: Result := ((v >= 0) and (v <= 32)); 345 | c0to32no10: Result := ((v >= 0) and (v <= 32) and (v <> 10)); 346 | cLoAtoF: Result := (v >= ordLA) and (v <= ordLF); 347 | cHiAtoF: Result := (v >= ordHA) and (v <= ordHF); 348 | cLoAtoZ: Result := (v >= ordLA) and (v <= ordLZ); 349 | cHiAtoZ: Result := (v >= ordHA) and (v <= ordHZ); 350 | cHex: Result := ((v >= ordLA) and (v <= ordLF)) or ((v >= ordHA) and (v <= ordHF)) or ((v >= ord0) and (v <= ord9)); 351 | cAtoF: Result := ((v >= ordLA) and (v <= ordLF)) or ((v >= ordHA) and (v <= ordHF)); 352 | cAtoZ: Result := ((v >= ordLA) and (v <= ordLZ)) or ((v >= ordHA) and (v <= ordHZ)); 353 | else Result := False; 354 | end; 355 | end; 356 | 357 | function CharIn(c: SystemChar; const SomeCharsets: TOrdChars): Boolean; 358 | var 359 | i: TOrdChar; 360 | begin 361 | Result := True; 362 | for i in SomeCharsets do 363 | if CharIn(c, i) then 364 | Exit; 365 | Result := False; 366 | end; 367 | 368 | function CharIn(c: SystemChar; const SomeCharsets: TOrdChars; const SomeChars: TPascalString): Boolean; 369 | begin 370 | if CharIn(c, SomeCharsets) then 371 | Result := True 372 | else 373 | Result := CharIn(c, SomeChars); 374 | end; 375 | 376 | function CharIn(c: SystemChar; const SomeCharsets: TOrdChars; const p: PPascalString): Boolean; 377 | begin 378 | if CharIn(c, SomeCharsets) then 379 | Result := True 380 | else 381 | Result := CharIn(c, p); 382 | end; 383 | 384 | function BytesOfPascalString(const s: TPascalString): TBytes; 385 | begin 386 | Result := s.Bytes; 387 | end; 388 | 389 | function PascalStringOfBytes(const s: TBytes): TPascalString; 390 | begin 391 | Result.Bytes := s; 392 | end; 393 | 394 | function FastHashPSystemString(const s: PSystemString): THash; 395 | var 396 | i: Integer; 397 | c: SystemChar; 398 | begin 399 | Result := 0; 400 | 401 | {$IFDEF FirstCharInZero} 402 | for i := 0 to length(s^) - 1 do 403 | {$ELSE} 404 | for i := 1 to length(s^) do 405 | {$ENDIF} 406 | begin 407 | c := s^[i]; 408 | if CharIn(c, cHiAtoZ) then 409 | inc(c, 32); 410 | Result := ((Result shl 7) or (Result shr 25)) + THash(c); 411 | end; 412 | end; 413 | 414 | function FastHash64PSystemString(const s: PSystemString): THash64; 415 | var 416 | i: Integer; 417 | c: SystemChar; 418 | begin 419 | Result := 0; 420 | 421 | {$IFDEF FirstCharInZero} 422 | for i := 0 to length(s^) - 1 do 423 | {$ELSE} 424 | for i := 1 to length(s^) do 425 | {$ENDIF} 426 | begin 427 | c := s^[i]; 428 | if CharIn(c, cHiAtoZ) then 429 | inc(c, 32); 430 | Result := ((Result shl 7) or (Result shr 57)) + THash64(c); 431 | end; 432 | end; 433 | 434 | function FastHashSystemString(const s: SystemString): THash; 435 | begin 436 | Result := FastHashPSystemString(@s); 437 | end; 438 | 439 | function FastHash64SystemString(const s: SystemString): THash64; 440 | begin 441 | Result := FastHash64PSystemString(@s); 442 | end; 443 | 444 | function FastHashPPascalString(const s: PPascalString): THash; 445 | var 446 | i: Integer; 447 | c: SystemChar; 448 | begin 449 | Result := 0; 450 | for i := 1 to s^.Len do 451 | begin 452 | c := s^[i]; 453 | if CharIn(c, cHiAtoZ) then 454 | inc(c, 32); 455 | Result := ((Result shl 7) or (Result shr 25)) + THash(c); 456 | end; 457 | end; 458 | 459 | function FastHash64PPascalString(const s: PPascalString): THash64; 460 | var 461 | i: Integer; 462 | c: SystemChar; 463 | begin 464 | Result := 0; 465 | for i := 1 to s^.Len do 466 | begin 467 | c := s^[i]; 468 | if CharIn(c, cHiAtoZ) then 469 | inc(c, 32); 470 | Result := ((Result shl 7) or (Result shr 57)) + THash64(c); 471 | end; 472 | end; 473 | 474 | function PFormat(const Fmt: SystemString; const Args: array of const): SystemString; 475 | begin 476 | Result := Format(Fmt, Args); 477 | end; 478 | 479 | function GetSWMVMemory(const xLen, yLen: NativeInt): Pointer; inline; 480 | { optimized matrix performance } 481 | begin 482 | Result := System.AllocMem((xLen + 1) * (yLen + 1) * SizeOf(NativeInt)); 483 | end; 484 | 485 | function GetSWMV(const p: Pointer; const w, x, y: NativeInt): NativeInt; inline; 486 | { optimized matrix performance } 487 | begin 488 | Result := PNativeInt(nativeUInt(p) + ((x + y * (w + 1)) * SizeOf(NativeInt)))^; 489 | end; 490 | 491 | procedure SetSWMV(const p: Pointer; const w, x, y: NativeInt; const v: NativeInt); inline; 492 | { optimized matrix performance } 493 | begin 494 | PNativeInt(nativeUInt(p) + ((x + y * (w + 1)) * SizeOf(NativeInt)))^ := v; 495 | end; 496 | 497 | function GetMax(const i1, i2: NativeInt): NativeInt; inline; 498 | begin 499 | if i1 > i2 then 500 | Result := i1 501 | else 502 | Result := i2; 503 | end; 504 | 505 | const 506 | SmithWaterman_MatchOk = 1; 507 | mismatch_penalty = -1; 508 | gap_penalty = -1; 509 | 510 | function SmithWatermanCompare(const seq1, seq2: PPascalString; var diff1, diff2: TPascalString; 511 | const NoDiffChar: Boolean; const diffChar: SystemChar): Double; 512 | 513 | function InlineMatch(alphaC, betaC: SystemChar; const diffC: SystemChar): Integer; inline; 514 | begin 515 | if CharIn(alphaC, cLoAtoZ) then 516 | dec(alphaC, 32); 517 | if CharIn(betaC, cLoAtoZ) then 518 | dec(betaC, 32); 519 | 520 | if alphaC = betaC then 521 | Result := SmithWaterman_MatchOk 522 | else if (alphaC = diffC) or (betaC = diffC) then 523 | Result := gap_penalty 524 | else 525 | Result := mismatch_penalty; 526 | end; 527 | 528 | var 529 | swMatrixPtr: Pointer; 530 | i, j, L1, l2: NativeInt; 531 | matched, deleted, inserted: NativeInt; 532 | score_current, score_diagonal, score_left, score_right: NativeInt; 533 | identity: NativeInt; 534 | align1, align2: TPascalString; 535 | begin 536 | L1 := seq1^.Len; 537 | l2 := seq2^.Len; 538 | 539 | if (L1 = 0) or (l2 = 0) or (L1 > MaxSmithWatermanMatrix) or (l2 > MaxSmithWatermanMatrix) then 540 | begin 541 | Result := -1; 542 | Exit; 543 | end; 544 | 545 | { fast build matrix } 546 | swMatrixPtr := GetSWMVMemory(L1, l2); 547 | if swMatrixPtr = nil then 548 | begin 549 | diff1 := ''; 550 | diff2 := ''; 551 | Result := -1; 552 | Exit; 553 | end; 554 | 555 | i := 0; 556 | while i <= L1 do 557 | begin 558 | SetSWMV(swMatrixPtr, L1, i, 0, gap_penalty * i); 559 | inc(i); 560 | end; 561 | 562 | j := 0; 563 | while j <= l2 do 564 | begin 565 | SetSWMV(swMatrixPtr, L1, 0, j, gap_penalty * j); 566 | inc(j); 567 | end; 568 | 569 | { compute matrix } 570 | i := 1; 571 | while i <= L1 do 572 | begin 573 | j := 1; 574 | while j <= l2 do 575 | begin 576 | matched := GetSWMV(swMatrixPtr, L1, i - 1, j - 1) + InlineMatch(seq1^[i], seq2^[j], diffChar); 577 | deleted := GetSWMV(swMatrixPtr, L1, i - 1, j) + gap_penalty; 578 | inserted := GetSWMV(swMatrixPtr, L1, i, j - 1) + gap_penalty; 579 | SetSWMV(swMatrixPtr, L1, i, j, GetMax(matched, GetMax(deleted, inserted))); 580 | inc(j); 581 | end; 582 | inc(i); 583 | end; 584 | 585 | { compute align } 586 | i := L1; 587 | j := l2; 588 | align1 := ''; 589 | align2 := ''; 590 | identity := 0; 591 | while (i > 0) and (j > 0) do 592 | begin 593 | score_current := GetSWMV(swMatrixPtr, L1, i, j); 594 | score_diagonal := GetSWMV(swMatrixPtr, L1, i - 1, j - 1); 595 | score_left := GetSWMV(swMatrixPtr, L1, i - 1, j); 596 | score_right := GetSWMV(swMatrixPtr, L1, i, j - 1); 597 | 598 | matched := InlineMatch(seq1^[i], seq2^[j], diffChar); 599 | 600 | if score_current = score_diagonal + matched then 601 | begin 602 | if matched = SmithWaterman_MatchOk then 603 | begin 604 | inc(identity); 605 | align1.Append(seq1^[i]); 606 | align2.Append(seq2^[j]); 607 | end 608 | else if NoDiffChar then 609 | begin 610 | align1.Append(diffChar); 611 | align2.Append(diffChar); 612 | end 613 | else 614 | begin 615 | align1.Append(seq1^[i]); 616 | align2.Append(seq2^[j]); 617 | end; 618 | dec(i); 619 | dec(j); 620 | end 621 | else if score_current = score_left + gap_penalty then 622 | begin 623 | if NoDiffChar then 624 | align1.Append(diffChar) 625 | else 626 | align1.Append(seq1^[i]); 627 | align2.Append(diffChar); 628 | dec(i); 629 | end 630 | else if score_current = score_right + gap_penalty then 631 | begin 632 | if NoDiffChar then 633 | align2.Append(diffChar) 634 | else 635 | align2.Append(seq2^[j]); 636 | align1.Append(diffChar); 637 | dec(j); 638 | end 639 | else 640 | raise Exception.Create('matrix error'); // matrix debug time 641 | end; 642 | 643 | System.FreeMemory(swMatrixPtr); 644 | 645 | while i > 0 do 646 | begin 647 | if NoDiffChar then 648 | align1.Append(diffChar) 649 | else 650 | align1.Append(seq1^[i]); 651 | align2.Append(diffChar); 652 | dec(i); 653 | end; 654 | 655 | while j > 0 do 656 | begin 657 | if NoDiffChar then 658 | align2.Append(diffChar) 659 | else 660 | align2.Append(seq2^[j]); 661 | align1.Append(diffChar); 662 | dec(j); 663 | end; 664 | 665 | if identity > 0 then 666 | Result := identity / align1.Len 667 | else 668 | Result := -1; 669 | 670 | diff1 := align1.Invert; 671 | diff2 := align2.Invert; 672 | end; 673 | 674 | function SmithWatermanCompare(const seq1, seq2: PPascalString; var diff1, diff2: TPascalString): Double; 675 | begin 676 | Result := SmithWatermanCompare(seq1, seq2, diff1, diff2, False, '-'); 677 | end; 678 | 679 | function SmithWatermanCompare(const seq1, seq2: TPascalString; var diff1, diff2: TPascalString; 680 | const NoDiffChar: Boolean; const diffChar: SystemChar): Double; 681 | begin 682 | Result := SmithWatermanCompare(@seq1, @seq2, diff1, diff2, NoDiffChar, diffChar); 683 | end; 684 | 685 | function SmithWatermanCompare(const seq1, seq2: TPascalString; var diff1, diff2: TPascalString): Double; 686 | begin 687 | Result := SmithWatermanCompare(seq1, seq2, diff1, diff2, False, '-'); 688 | end; 689 | 690 | function SmithWatermanCompare(const seq1, seq2: PPascalString; out Same, Diff: Integer): Double; 691 | 692 | function InlineMatch(alphaC, betaC: SystemChar): NativeInt; inline; 693 | begin 694 | if CharIn(alphaC, cLoAtoZ) then 695 | dec(alphaC, 32); 696 | if CharIn(betaC, cLoAtoZ) then 697 | dec(betaC, 32); 698 | 699 | if alphaC = betaC then 700 | Result := SmithWaterman_MatchOk 701 | else 702 | Result := mismatch_penalty; 703 | end; 704 | 705 | var 706 | swMatrixPtr: Pointer; 707 | i, j, L1, l2: NativeInt; 708 | matched, deleted, inserted: NativeInt; 709 | score_current, score_diagonal, score_left, score_right: NativeInt; 710 | identity, L: NativeInt; 711 | begin 712 | L1 := seq1^.Len; 713 | l2 := seq2^.Len; 714 | 715 | if (L1 = 0) or (l2 = 0) or (L1 > MaxSmithWatermanMatrix) or (l2 > MaxSmithWatermanMatrix) then 716 | begin 717 | Result := -1; 718 | Same := 0; 719 | Diff := L1 + l2; 720 | Exit; 721 | end; 722 | 723 | { fast build matrix } 724 | swMatrixPtr := GetSWMVMemory(L1, l2); 725 | if swMatrixPtr = nil then 726 | begin 727 | Result := -1; 728 | Exit; 729 | end; 730 | 731 | i := 0; 732 | while i <= L1 do 733 | begin 734 | SetSWMV(swMatrixPtr, L1, i, 0, gap_penalty * i); 735 | inc(i); 736 | end; 737 | 738 | j := 0; 739 | while j <= l2 do 740 | begin 741 | SetSWMV(swMatrixPtr, L1, 0, j, gap_penalty * j); 742 | inc(j); 743 | end; 744 | 745 | { compute matrix } 746 | i := 1; 747 | while i <= L1 do 748 | begin 749 | j := 1; 750 | while j <= l2 do 751 | begin 752 | matched := GetSWMV(swMatrixPtr, L1, i - 1, j - 1) + InlineMatch(seq1^[i], seq2^[j]); 753 | deleted := GetSWMV(swMatrixPtr, L1, i - 1, j) + gap_penalty; 754 | inserted := GetSWMV(swMatrixPtr, L1, i, j - 1) + gap_penalty; 755 | SetSWMV(swMatrixPtr, L1, i, j, GetMax(matched, GetMax(deleted, inserted))); 756 | inc(j); 757 | end; 758 | inc(i); 759 | end; 760 | 761 | { compute align } 762 | i := L1; 763 | j := l2; 764 | identity := 0; 765 | L := 0; 766 | while (i > 0) and (j > 0) do 767 | begin 768 | score_current := GetSWMV(swMatrixPtr, L1, i, j); 769 | score_diagonal := GetSWMV(swMatrixPtr, L1, i - 1, j - 1); 770 | score_left := GetSWMV(swMatrixPtr, L1, i - 1, j); 771 | score_right := GetSWMV(swMatrixPtr, L1, i, j - 1); 772 | matched := InlineMatch(seq1^[i], seq2^[j]); 773 | 774 | if score_current = score_diagonal + matched then 775 | begin 776 | if matched = SmithWaterman_MatchOk then 777 | inc(identity); 778 | 779 | inc(L); 780 | dec(i); 781 | dec(j); 782 | end 783 | else if score_current = score_left + gap_penalty then 784 | begin 785 | inc(L); 786 | dec(i); 787 | end 788 | else if score_current = score_right + gap_penalty then 789 | begin 790 | inc(L); 791 | dec(j); 792 | end 793 | else 794 | raise Exception.Create('matrix error'); // matrix debug time 795 | end; 796 | 797 | System.FreeMemory(swMatrixPtr); 798 | 799 | if identity > 0 then 800 | begin 801 | Result := identity / (L + i + j); 802 | Same := identity; 803 | Diff := (L + i + j) - identity; 804 | end 805 | else 806 | begin 807 | Result := -1; 808 | Same := 0; 809 | Diff := L + i + j; 810 | end; 811 | end; 812 | 813 | function SmithWatermanCompare(const seq1, seq2: PPascalString): Double; 814 | var 815 | Same, Diff: Integer; 816 | begin 817 | Result := SmithWatermanCompare(seq1, seq2, Same, Diff); 818 | end; 819 | 820 | function SmithWatermanCompare(const seq1, seq2: TPascalString): Double; 821 | begin 822 | Result := SmithWatermanCompare(@seq1, @seq2); 823 | end; 824 | 825 | function SmithWatermanCompare(const seq1: TArrayPascalString; const seq2: TPascalString): Double; 826 | var 827 | i: Integer; 828 | r: Double; 829 | begin 830 | Result := -1; 831 | for i := 0 to length(seq1) - 1 do 832 | begin 833 | r := SmithWatermanCompare(seq1[i], seq2); 834 | if r > Result then 835 | Result := r; 836 | end; 837 | end; 838 | 839 | function SmithWatermanCompare(const seq1: Pointer; siz1: Integer; const seq2: Pointer; siz2: Integer; 840 | out Same, Diff: Integer): Double; 841 | 842 | function InlineMatch(const alphaB, betaB: Byte): NativeInt; inline; 843 | begin 844 | if alphaB = betaB then 845 | Result := SmithWaterman_MatchOk 846 | else 847 | Result := mismatch_penalty; 848 | end; 849 | 850 | var 851 | swMatrixPtr: Pointer; 852 | i, j, L1, l2: NativeInt; 853 | matched, deleted, inserted: NativeInt; 854 | score_current, score_diagonal, score_left, score_right: NativeInt; 855 | identity, L: NativeInt; 856 | begin 857 | L1 := siz1; 858 | l2 := siz2; 859 | 860 | if (L1 = 0) or (l2 = 0) or (L1 > MaxSmithWatermanMatrix) or (l2 > MaxSmithWatermanMatrix) then 861 | begin 862 | Result := -1; 863 | Same := 0; 864 | Diff := L1 + l2; 865 | Exit; 866 | end; 867 | 868 | { fast build matrix } 869 | swMatrixPtr := GetSWMVMemory(L1, l2); 870 | if swMatrixPtr = nil then 871 | begin 872 | Result := -1; 873 | Exit; 874 | end; 875 | 876 | i := 0; 877 | while i <= L1 do 878 | begin 879 | SetSWMV(swMatrixPtr, L1, i, 0, gap_penalty * i); 880 | inc(i); 881 | end; 882 | 883 | j := 0; 884 | while j <= l2 do 885 | begin 886 | SetSWMV(swMatrixPtr, L1, 0, j, gap_penalty * j); 887 | inc(j); 888 | end; 889 | 890 | { compute matrix } 891 | i := 1; 892 | while i <= L1 do 893 | begin 894 | j := 1; 895 | while j <= l2 do 896 | begin 897 | matched := GetSWMV(swMatrixPtr, L1, i - 1, j - 1) + InlineMatch(PByte(nativeUInt(seq1) + (i - 1))^, PByte(nativeUInt(seq2) + (j - 1))^); 898 | deleted := GetSWMV(swMatrixPtr, L1, i - 1, j) + gap_penalty; 899 | inserted := GetSWMV(swMatrixPtr, L1, i, j - 1) + gap_penalty; 900 | SetSWMV(swMatrixPtr, L1, i, j, GetMax(matched, GetMax(deleted, inserted))); 901 | inc(j); 902 | end; 903 | inc(i); 904 | end; 905 | 906 | { compute align } 907 | i := L1; 908 | j := l2; 909 | identity := 0; 910 | L := 0; 911 | while (i > 0) and (j > 0) do 912 | begin 913 | score_current := GetSWMV(swMatrixPtr, L1, i, j); 914 | score_diagonal := GetSWMV(swMatrixPtr, L1, i - 1, j - 1); 915 | score_left := GetSWMV(swMatrixPtr, L1, i - 1, j); 916 | score_right := GetSWMV(swMatrixPtr, L1, i, j - 1); 917 | matched := InlineMatch(PByte(nativeUInt(seq1) + (i - 1))^, PByte(nativeUInt(seq2) + (j - 1))^); 918 | 919 | if score_current = score_diagonal + matched then 920 | begin 921 | if matched = SmithWaterman_MatchOk then 922 | inc(identity); 923 | 924 | inc(L); 925 | dec(i); 926 | dec(j); 927 | end 928 | else if score_current = score_left + gap_penalty then 929 | begin 930 | inc(L); 931 | dec(i); 932 | end 933 | else if score_current = score_right + gap_penalty then 934 | begin 935 | inc(L); 936 | dec(j); 937 | end 938 | else 939 | raise Exception.Create('matrix error'); // matrix debug time 940 | end; 941 | 942 | System.FreeMemory(swMatrixPtr); 943 | 944 | if identity > 0 then 945 | begin 946 | Result := identity / (L + i + j); 947 | Same := identity; 948 | Diff := (L + i + j) - identity; 949 | end 950 | else 951 | begin 952 | Result := -1; 953 | Same := 0; 954 | Diff := L + i + j; 955 | end; 956 | end; 957 | 958 | function SmithWatermanCompare(const seq1: Pointer; siz1: Integer; const seq2: Pointer; siz2: Integer): Double; 959 | var 960 | Same, Diff: Integer; 961 | begin 962 | Result := SmithWatermanCompare(seq1, siz1, seq2, siz2, Same, Diff); 963 | end; 964 | 965 | function SmithWatermanCompareLongString(const t1, t2: TPascalString; const MinDiffCharWithPeerLine: Integer; out Same, Diff: Integer): Double; 966 | type 967 | PSRec = ^TSRec; 968 | 969 | TSRec = record 970 | s: TPascalString; 971 | end; 972 | 973 | procedure _FillText(psPtr: PPascalString; outLst: TCoreClassList); 974 | var 975 | L, i: Integer; 976 | n: TPascalString; 977 | p: PSRec; 978 | begin 979 | L := psPtr^.Len; 980 | i := 1; 981 | n := ''; 982 | while i <= L do 983 | begin 984 | if CharIn(psPtr^[i], [#13, #10]) then 985 | begin 986 | n := n.DeleteChar(#32#9); 987 | if n.Len > 0 then 988 | begin 989 | new(p); 990 | p^.s := n; 991 | outLst.Add(p); 992 | n := ''; 993 | end; 994 | repeat 995 | inc(i); 996 | until (i > L) or (not CharIn(psPtr^[i], [#13, #10, #32, #9])); 997 | end 998 | else 999 | begin 1000 | n.Append(psPtr^[i]); 1001 | inc(i); 1002 | end; 1003 | end; 1004 | 1005 | n := n.DeleteChar(#32#9); 1006 | if n.Len > 0 then 1007 | begin 1008 | new(p); 1009 | p^.s := n; 1010 | outLst.Add(p); 1011 | end; 1012 | end; 1013 | 1014 | function InlineMatch(const alpha, beta: PSRec; const MinDiffCharWithPeerLine: Integer; var cSame, cDiff: Integer): NativeInt; inline; 1015 | begin 1016 | if SmithWatermanCompare(@alpha^.s, @beta^.s, cSame, cDiff) > 0 then 1017 | begin 1018 | if cDiff < MinDiffCharWithPeerLine then 1019 | Result := SmithWaterman_MatchOk 1020 | else 1021 | Result := mismatch_penalty; 1022 | end 1023 | else 1024 | Result := mismatch_penalty; 1025 | end; 1026 | 1027 | var 1028 | lst1, lst2: TCoreClassList; 1029 | 1030 | procedure _Init; 1031 | begin 1032 | lst1 := TCoreClassList.Create; 1033 | lst2 := TCoreClassList.Create; 1034 | _FillText(@t1, lst1); 1035 | _FillText(@t2, lst2); 1036 | end; 1037 | 1038 | procedure _Free; 1039 | var 1040 | i: Integer; 1041 | begin 1042 | for i := 0 to lst1.Count - 1 do 1043 | Dispose(PSRec(lst1[i])); 1044 | for i := 0 to lst2.Count - 1 do 1045 | Dispose(PSRec(lst2[i])); 1046 | DisposeObject([lst1, lst2]); 1047 | end; 1048 | 1049 | var 1050 | swMatrixPtr: Pointer; 1051 | i, j, L1, l2: NativeInt; 1052 | matched, deleted, inserted: NativeInt; 1053 | score_current, score_diagonal, score_left, score_right: NativeInt; 1054 | cSame, cDiff, TotalSame, TotalDiff: Integer; 1055 | begin 1056 | _Init; 1057 | L1 := lst1.Count; 1058 | l2 := lst2.Count; 1059 | 1060 | if (L1 = 0) or (l2 = 0) or (L1 > MaxSmithWatermanMatrix) or (l2 > MaxSmithWatermanMatrix) then 1061 | begin 1062 | Result := -1; 1063 | Same := 0; 1064 | Diff := L1 + l2; 1065 | _Free; 1066 | Exit; 1067 | end; 1068 | 1069 | { fast build matrix } 1070 | swMatrixPtr := GetSWMVMemory(L1, l2); 1071 | if swMatrixPtr = nil then 1072 | begin 1073 | Result := -1; 1074 | _Free; 1075 | Exit; 1076 | end; 1077 | 1078 | i := 0; 1079 | while i <= L1 do 1080 | begin 1081 | SetSWMV(swMatrixPtr, L1, i, 0, gap_penalty * i); 1082 | inc(i); 1083 | end; 1084 | 1085 | j := 0; 1086 | while j <= l2 do 1087 | begin 1088 | SetSWMV(swMatrixPtr, L1, 0, j, gap_penalty * j); 1089 | inc(j); 1090 | end; 1091 | 1092 | { compute matrix } 1093 | i := 1; 1094 | while i <= L1 do 1095 | begin 1096 | j := 1; 1097 | while j <= l2 do 1098 | begin 1099 | matched := GetSWMV(swMatrixPtr, L1, i - 1, j - 1) + InlineMatch(PSRec(lst1[i - 1]), PSRec(lst2[j - 1]), MinDiffCharWithPeerLine, cSame, cDiff); 1100 | deleted := GetSWMV(swMatrixPtr, L1, i - 1, j) + gap_penalty; 1101 | inserted := GetSWMV(swMatrixPtr, L1, i, j - 1) + gap_penalty; 1102 | SetSWMV(swMatrixPtr, L1, i, j, GetMax(matched, GetMax(deleted, inserted))); 1103 | inc(j); 1104 | end; 1105 | inc(i); 1106 | end; 1107 | 1108 | { compute align } 1109 | i := L1; 1110 | j := l2; 1111 | TotalSame := 0; 1112 | TotalDiff := 0; 1113 | while (i > 0) and (j > 0) do 1114 | begin 1115 | score_current := GetSWMV(swMatrixPtr, L1, i, j); 1116 | score_diagonal := GetSWMV(swMatrixPtr, L1, i - 1, j - 1); 1117 | score_left := GetSWMV(swMatrixPtr, L1, i - 1, j); 1118 | score_right := GetSWMV(swMatrixPtr, L1, i, j - 1); 1119 | matched := InlineMatch(PSRec(lst1[i - 1]), PSRec(lst2[j - 1]), MinDiffCharWithPeerLine, cSame, cDiff); 1120 | 1121 | inc(TotalSame, cSame); 1122 | inc(TotalDiff, cDiff); 1123 | 1124 | if score_current = score_diagonal + matched then 1125 | begin 1126 | dec(i); 1127 | dec(j); 1128 | end 1129 | else if score_current = score_left + gap_penalty then 1130 | begin 1131 | dec(i); 1132 | end 1133 | else if score_current = score_right + gap_penalty then 1134 | begin 1135 | dec(j); 1136 | end 1137 | else 1138 | raise Exception.Create('matrix error'); // matrix debug time 1139 | end; 1140 | 1141 | System.FreeMemory(swMatrixPtr); 1142 | _Free; 1143 | 1144 | if TotalSame > 0 then 1145 | begin 1146 | Result := TotalSame / (TotalSame + TotalDiff); 1147 | Same := TotalSame; 1148 | Diff := TotalDiff; 1149 | end 1150 | else 1151 | begin 1152 | Result := -1; 1153 | Same := 0; 1154 | Diff := t2.Len + t1.Len; 1155 | end; 1156 | end; 1157 | 1158 | function SmithWatermanCompareLongString(const t1, t2: TPascalString): Double; 1159 | var 1160 | Same, Diff: Integer; 1161 | begin 1162 | Result := SmithWatermanCompareLongString(t1, t2, 5, Same, Diff); 1163 | end; 1164 | 1165 | {$IFDEF FPC} 1166 | 1167 | 1168 | operator := (const s: Variant)r: TPascalString; 1169 | begin 1170 | r.Text := s; 1171 | end; 1172 | 1173 | operator := (const s: AnsiString)r: TPascalString; 1174 | begin 1175 | r.Text := s; 1176 | end; 1177 | 1178 | operator := (const s: UnicodeString)r: TPascalString; 1179 | begin 1180 | r.Text := s; 1181 | end; 1182 | 1183 | operator := (const s: WideString)r: TPascalString; 1184 | begin 1185 | r.Text := s; 1186 | end; 1187 | 1188 | operator := (const s: ShortString)r: TPascalString; 1189 | begin 1190 | r.Text := s; 1191 | end; 1192 | 1193 | operator := (const c: SystemChar)r: TPascalString; 1194 | begin 1195 | r.Text := c; 1196 | end; 1197 | 1198 | operator := (const s: TPascalString)r: AnsiString; 1199 | begin 1200 | r := s.Text; 1201 | end; 1202 | 1203 | operator := (const s: TPascalString)r: UnicodeString; 1204 | begin 1205 | r := s.Text; 1206 | end; 1207 | 1208 | operator := (const s: TPascalString)r: WideString; 1209 | begin 1210 | r := s.Text; 1211 | end; 1212 | 1213 | operator := (const s: TPascalString)r: ShortString; 1214 | begin 1215 | r := s.Text; 1216 | end; 1217 | 1218 | operator := (const s: TPascalString)r: Variant; 1219 | begin 1220 | r := s.Text; 1221 | end; 1222 | 1223 | operator = (const a: TPascalString; const b: TPascalString): Boolean; 1224 | begin 1225 | Result := a.Text = b.Text; 1226 | end; 1227 | 1228 | operator <> (const a: TPascalString; const b: TPascalString): Boolean; 1229 | begin 1230 | Result := a.Text <> b.Text; 1231 | end; 1232 | 1233 | operator > (const a: TPascalString; const b: TPascalString): Boolean; 1234 | begin 1235 | Result := a.Text > b.Text; 1236 | end; 1237 | 1238 | operator >= (const a: TPascalString; const b: TPascalString): Boolean; 1239 | begin 1240 | Result := a.Text >= b.Text; 1241 | end; 1242 | 1243 | operator < (const a: TPascalString; const b: TPascalString): Boolean; 1244 | begin 1245 | Result := a.Text < b.Text; 1246 | end; 1247 | 1248 | operator <= (const a: TPascalString; const b: TPascalString): Boolean; 1249 | begin 1250 | Result := a.Text <= b.Text; 1251 | end; 1252 | 1253 | operator + (const a: TPascalString; const b: TPascalString): TPascalString; 1254 | begin 1255 | CombineCharsPP(a.buff, b.buff, Result.buff); 1256 | end; 1257 | 1258 | operator + (const a: TPascalString; const b: SystemString): TPascalString; 1259 | begin 1260 | CombineCharsPS(a.buff, b, Result.buff); 1261 | end; 1262 | 1263 | operator + (const a: SystemString; const b: TPascalString): TPascalString; 1264 | begin 1265 | CombineCharsSP(a, b.buff, Result.buff); 1266 | end; 1267 | 1268 | operator + (const a: TPascalString; const b: SystemChar): TPascalString; 1269 | begin 1270 | CombineCharsPC(a.buff, b, Result.buff); 1271 | end; 1272 | 1273 | operator + (const a: SystemChar; const b: TPascalString): TPascalString; 1274 | begin 1275 | CombineCharsCP(a, b.buff, Result.buff); 1276 | end; 1277 | 1278 | {$ENDIF} 1279 | 1280 | 1281 | function TPascalString.GetText: SystemString; 1282 | begin 1283 | SetLength(Result, length(buff)); 1284 | if length(buff) > 0 then 1285 | CopyPtr(@buff[0], @Result[FirstCharPos], length(buff) * SystemCharSize); 1286 | end; 1287 | 1288 | procedure TPascalString.SetText(const Value: SystemString); 1289 | begin 1290 | SetLength(buff, length(Value)); 1291 | 1292 | if length(buff) > 0 then 1293 | CopyPtr(@Value[FirstCharPos], @buff[0], length(buff) * SystemCharSize); 1294 | end; 1295 | 1296 | function TPascalString.GetLen: Integer; 1297 | begin 1298 | Result := length(buff); 1299 | end; 1300 | 1301 | procedure TPascalString.SetLen(const Value: Integer); 1302 | begin 1303 | SetLength(buff, Value); 1304 | end; 1305 | 1306 | function TPascalString.GetChars(index: Integer): SystemChar; 1307 | begin 1308 | if (index > length(buff)) or (index <= 0) then 1309 | Result := #0 1310 | else 1311 | Result := buff[index - 1]; 1312 | end; 1313 | 1314 | procedure TPascalString.SetChars(index: Integer; const Value: SystemChar); 1315 | begin 1316 | buff[index - 1] := Value; 1317 | end; 1318 | 1319 | procedure TPascalString.SetBytes(const Value: TBytes); 1320 | begin 1321 | SetLength(buff, 0); 1322 | try 1323 | Text := SysUtils.TEncoding.UTF8.GetString(Value); 1324 | except 1325 | SetLength(buff, 0); 1326 | end; 1327 | end; 1328 | 1329 | function TPascalString.GetBytes: TBytes; 1330 | begin 1331 | {$IFDEF FPC} 1332 | Result := SysUtils.TEncoding.UTF8.GetBytes(Text); 1333 | {$ELSE} 1334 | Result := SysUtils.TEncoding.UTF8.GetBytes(buff); 1335 | {$ENDIF} 1336 | end; 1337 | 1338 | function TPascalString.GetLast: SystemChar; 1339 | begin 1340 | Result := buff[length(buff) - 1]; 1341 | end; 1342 | 1343 | procedure TPascalString.SetLast(const Value: SystemChar); 1344 | begin 1345 | buff[length(buff) - 1] := Value; 1346 | end; 1347 | 1348 | function TPascalString.GetFirst: SystemChar; 1349 | begin 1350 | Result := buff[0]; 1351 | end; 1352 | 1353 | procedure TPascalString.SetFirst(const Value: SystemChar); 1354 | begin 1355 | buff[0] := Value; 1356 | end; 1357 | 1358 | {$IFDEF DELPHI} 1359 | 1360 | 1361 | class operator TPascalString.Equal(const Lhs, Rhs: TPascalString): Boolean; 1362 | begin 1363 | Result := (Lhs.Len = Rhs.Len) and (Lhs.Text = Rhs.Text); 1364 | end; 1365 | 1366 | class operator TPascalString.NotEqual(const Lhs, Rhs: TPascalString): Boolean; 1367 | begin 1368 | Result := not(Lhs = Rhs); 1369 | end; 1370 | 1371 | class operator TPascalString.GreaterThan(const Lhs, Rhs: TPascalString): Boolean; 1372 | begin 1373 | Result := Lhs.Text > Rhs.Text; 1374 | end; 1375 | 1376 | class operator TPascalString.GreaterThanOrEqual(const Lhs, Rhs: TPascalString): Boolean; 1377 | begin 1378 | Result := Lhs.Text >= Rhs.Text; 1379 | end; 1380 | 1381 | class operator TPascalString.LessThan(const Lhs, Rhs: TPascalString): Boolean; 1382 | begin 1383 | Result := Lhs.Text < Rhs.Text; 1384 | end; 1385 | 1386 | class operator TPascalString.LessThanOrEqual(const Lhs, Rhs: TPascalString): Boolean; 1387 | begin 1388 | Result := Lhs.Text <= Rhs.Text; 1389 | end; 1390 | 1391 | class operator TPascalString.Add(const Lhs, Rhs: TPascalString): TPascalString; 1392 | begin 1393 | CombineCharsPP(Lhs.buff, Rhs.buff, Result.buff); 1394 | end; 1395 | 1396 | class operator TPascalString.Add(const Lhs: SystemString; const Rhs: TPascalString): TPascalString; 1397 | begin 1398 | CombineCharsSP(Lhs, Rhs.buff, Result.buff); 1399 | end; 1400 | 1401 | class operator TPascalString.Add(const Lhs: TPascalString; const Rhs: SystemString): TPascalString; 1402 | begin 1403 | CombineCharsPS(Lhs.buff, Rhs, Result.buff); 1404 | end; 1405 | 1406 | class operator TPascalString.Add(const Lhs: SystemChar; const Rhs: TPascalString): TPascalString; 1407 | begin 1408 | CombineCharsCP(Lhs, Rhs.buff, Result.buff); 1409 | end; 1410 | 1411 | class operator TPascalString.Add(const Lhs: TPascalString; const Rhs: SystemChar): TPascalString; 1412 | begin 1413 | CombineCharsPC(Lhs.buff, Rhs, Result.buff); 1414 | end; 1415 | 1416 | class operator TPascalString.Implicit(Value: Variant): TPascalString; 1417 | begin 1418 | Result.Text := VarToStr(Value); 1419 | end; 1420 | 1421 | class operator TPascalString.Implicit(Value: SystemString): TPascalString; 1422 | begin 1423 | Result.Text := Value; 1424 | end; 1425 | 1426 | class operator TPascalString.Implicit(Value: SystemChar): TPascalString; 1427 | begin 1428 | Result.Len := 1; 1429 | Result.buff[0] := Value; 1430 | end; 1431 | 1432 | class operator TPascalString.Implicit(Value: TPascalString): SystemString; 1433 | begin 1434 | Result := Value.Text; 1435 | end; 1436 | 1437 | class operator TPascalString.Implicit(Value: TPascalString): Variant; 1438 | begin 1439 | Result := Value.Text; 1440 | end; 1441 | 1442 | class operator TPascalString.Explicit(Value: TPascalString): SystemString; 1443 | begin 1444 | Result := Value.Text; 1445 | end; 1446 | 1447 | class operator TPascalString.Explicit(Value: TPascalString): Variant; 1448 | begin 1449 | Result := Value.Text; 1450 | end; 1451 | 1452 | class operator TPascalString.Explicit(Value: SystemString): TPascalString; 1453 | begin 1454 | Result.Text := Value; 1455 | end; 1456 | 1457 | class operator TPascalString.Explicit(Value: Variant): TPascalString; 1458 | begin 1459 | Result.Text := VarToStr(Value); 1460 | end; 1461 | 1462 | class operator TPascalString.Explicit(Value: SystemChar): TPascalString; 1463 | begin 1464 | Result.Len := 1; 1465 | Result.buff[0] := Value; 1466 | end; 1467 | 1468 | {$ENDIF} 1469 | 1470 | 1471 | function TPascalString.Copy(index, Count: NativeInt): TPascalString; 1472 | var 1473 | L: NativeInt; 1474 | begin 1475 | L := length(buff); 1476 | 1477 | if (index - 1) + Count > L then 1478 | Count := L - (index - 1); 1479 | 1480 | SetLength(Result.buff, Count); 1481 | if Count > 0 then 1482 | CopyPtr(@buff[index - 1], @Result.buff[0], SystemCharSize * Count); 1483 | end; 1484 | 1485 | function TPascalString.Same(const p: PPascalString): Boolean; 1486 | var 1487 | i: Integer; 1488 | s, d: SystemChar; 1489 | begin 1490 | Result := (p^.Len = Len); 1491 | if not Result then 1492 | Exit; 1493 | for i := 0 to Len - 1 do 1494 | begin 1495 | s := buff[i]; 1496 | if CharIn(s, cHiAtoZ) then 1497 | inc(s, 32); 1498 | d := p^.buff[i]; 1499 | if CharIn(d, cHiAtoZ) then 1500 | inc(d, 32); 1501 | if s <> d then 1502 | Exit(False); 1503 | end; 1504 | end; 1505 | 1506 | function TPascalString.Same(const t: TPascalString): Boolean; 1507 | var 1508 | i: Integer; 1509 | s, d: SystemChar; 1510 | begin 1511 | Result := (t.Len = Len); 1512 | if not Result then 1513 | Exit; 1514 | for i := 0 to Len - 1 do 1515 | begin 1516 | s := buff[i]; 1517 | if CharIn(s, cHiAtoZ) then 1518 | inc(s, 32); 1519 | d := t.buff[i]; 1520 | if CharIn(d, cHiAtoZ) then 1521 | inc(d, 32); 1522 | if s <> d then 1523 | Exit(False); 1524 | end; 1525 | end; 1526 | 1527 | function TPascalString.Same(const t1, t2: TPascalString): Boolean; 1528 | begin 1529 | Result := Same(@t1) or Same(@t2); 1530 | end; 1531 | 1532 | function TPascalString.Same(const t1, t2, t3: TPascalString): Boolean; 1533 | begin 1534 | Result := Same(@t1) or Same(@t2) or Same(@t3); 1535 | end; 1536 | 1537 | function TPascalString.Same(const t1, t2, t3, t4: TPascalString): Boolean; 1538 | begin 1539 | Result := Same(@t1) or Same(@t2) or Same(@t3) or Same(@t4); 1540 | end; 1541 | 1542 | function TPascalString.Same(const t1, t2, t3, t4, t5: TPascalString): Boolean; 1543 | begin 1544 | Result := Same(@t1) or Same(@t2) or Same(@t3) or Same(@t4) or Same(@t5); 1545 | end; 1546 | 1547 | function TPascalString.Same(const IgnoreCase: Boolean; const t: TPascalString): Boolean; 1548 | var 1549 | i: Integer; 1550 | s, d: SystemChar; 1551 | begin 1552 | Result := (t.Len = Len); 1553 | if not Result then 1554 | Exit; 1555 | for i := 0 to Len - 1 do 1556 | begin 1557 | s := buff[i]; 1558 | if IgnoreCase then 1559 | if CharIn(s, cHiAtoZ) then 1560 | inc(s, 32); 1561 | 1562 | d := t.buff[i]; 1563 | if IgnoreCase then 1564 | if CharIn(d, cHiAtoZ) then 1565 | inc(d, 32); 1566 | 1567 | if s <> d then 1568 | Exit(False); 1569 | end; 1570 | end; 1571 | 1572 | function TPascalString.ComparePos(const Offset: Integer; const p: PPascalString): Boolean; 1573 | var 1574 | i, L: Integer; 1575 | sourChar, destChar: SystemChar; 1576 | begin 1577 | Result := False; 1578 | i := 1; 1579 | L := p^.Len; 1580 | if (Offset + L - 1) > Len then 1581 | Exit; 1582 | while i <= L do 1583 | begin 1584 | sourChar := GetChars(Offset + i - 1); 1585 | destChar := p^[i]; 1586 | 1587 | if CharIn(sourChar, cLoAtoZ) then 1588 | dec(sourChar, 32); 1589 | if CharIn(destChar, cLoAtoZ) then 1590 | dec(destChar, 32); 1591 | 1592 | if sourChar <> destChar then 1593 | Exit; 1594 | inc(i); 1595 | end; 1596 | Result := True; 1597 | end; 1598 | 1599 | function TPascalString.ComparePos(const Offset: Integer; const t: TPascalString): Boolean; 1600 | var 1601 | i, L: Integer; 1602 | sourChar, destChar: SystemChar; 1603 | begin 1604 | Result := False; 1605 | i := 1; 1606 | L := t.Len; 1607 | if (Offset + L) > Len then 1608 | Exit; 1609 | while i <= L do 1610 | begin 1611 | sourChar := GetChars(Offset + i - 1); 1612 | destChar := t[i]; 1613 | 1614 | if CharIn(sourChar, cLoAtoZ) then 1615 | dec(sourChar, 32); 1616 | if CharIn(destChar, cLoAtoZ) then 1617 | dec(destChar, 32); 1618 | 1619 | if sourChar <> destChar then 1620 | Exit; 1621 | inc(i); 1622 | end; 1623 | Result := True; 1624 | end; 1625 | 1626 | function TPascalString.GetPos(const s: TPascalString; const Offset: Integer = 1): Integer; 1627 | var 1628 | i: Integer; 1629 | begin 1630 | Result := 0; 1631 | if s.Len > 0 then 1632 | for i := Offset to Len - s.Len + 1 do 1633 | if ComparePos(i, @s) then 1634 | Exit(i); 1635 | end; 1636 | 1637 | function TPascalString.GetPos(const s: PPascalString; const Offset: Integer = 1): Integer; 1638 | var 1639 | i: Integer; 1640 | begin 1641 | Result := 0; 1642 | if s^.Len > 0 then 1643 | for i := Offset to Len - s^.Len + 1 do 1644 | if ComparePos(i, s) then 1645 | Exit(i); 1646 | end; 1647 | 1648 | function TPascalString.Exists(c: SystemChar): Boolean; 1649 | var 1650 | i: Integer; 1651 | begin 1652 | for i := low(buff) to high(buff) do 1653 | if buff[i] = c then 1654 | Exit(True); 1655 | Result := False; 1656 | end; 1657 | 1658 | function TPascalString.Exists(c: array of SystemChar): Boolean; 1659 | var 1660 | i: Integer; 1661 | begin 1662 | for i := low(buff) to high(buff) do 1663 | if CharIn(buff[i], c) then 1664 | Exit(True); 1665 | Result := False; 1666 | end; 1667 | 1668 | function TPascalString.Exists(const s: TPascalString): Boolean; 1669 | begin 1670 | Result := GetPos(@s, 1) > 0; 1671 | end; 1672 | 1673 | function TPascalString.GetCharCount(c: SystemChar): Integer; 1674 | var 1675 | i: Integer; 1676 | begin 1677 | Result := 0; 1678 | for i := low(buff) to high(buff) do 1679 | if CharIn(buff[i], c) then 1680 | inc(Result); 1681 | end; 1682 | 1683 | function TPascalString.hash: THash; 1684 | begin 1685 | Result := FastHashPPascalString(@Self); 1686 | end; 1687 | 1688 | function TPascalString.Hash64: THash64; 1689 | begin 1690 | Result := FastHash64PPascalString(@Self); 1691 | end; 1692 | 1693 | procedure TPascalString.DeleteLast; 1694 | begin 1695 | if Len > 0 then 1696 | SetLength(buff, length(buff) - 1); 1697 | end; 1698 | 1699 | procedure TPascalString.DeleteFirst; 1700 | begin 1701 | if Len > 0 then 1702 | buff := System.Copy(buff, 1, Len); 1703 | end; 1704 | 1705 | procedure TPascalString.Delete(idx, cnt: Integer); 1706 | begin 1707 | if (idx + cnt <= Len) then 1708 | Text := GetString(1, idx) + GetString(idx + cnt, Len + 1) 1709 | else 1710 | Text := GetString(1, idx); 1711 | end; 1712 | 1713 | procedure TPascalString.Clear; 1714 | begin 1715 | SetLength(buff, 0); 1716 | end; 1717 | 1718 | procedure TPascalString.Append(t: TPascalString); 1719 | var 1720 | r, L: Integer; 1721 | begin 1722 | L := length(t.buff); 1723 | if L > 0 then 1724 | begin 1725 | r := length(buff); 1726 | SetLength(buff, r + L); 1727 | CopyPtr(@t.buff[0], @buff[r], L * SystemCharSize); 1728 | end; 1729 | end; 1730 | 1731 | procedure TPascalString.Append(c: SystemChar); 1732 | begin 1733 | SetLength(buff, length(buff) + 1); 1734 | buff[length(buff) - 1] := c; 1735 | end; 1736 | 1737 | function TPascalString.GetString(bPos, ePos: NativeInt): TPascalString; 1738 | begin 1739 | if ePos > length(buff) then 1740 | Result := Self.Copy(bPos, length(buff) - bPos + 1) 1741 | else 1742 | Result := Self.Copy(bPos, (ePos - bPos)); 1743 | end; 1744 | 1745 | procedure TPascalString.Insert(AText: SystemString; idx: Integer); 1746 | begin 1747 | Text := GetString(1, idx) + AText + GetString(idx + 1, Len); 1748 | end; 1749 | 1750 | procedure TPascalString.FastAsText(var output: SystemString); 1751 | begin 1752 | SetLength(output, length(buff)); 1753 | if length(buff) > 0 then 1754 | CopyPtr(@buff[0], @output[FirstCharPos], length(buff) * SystemCharSize); 1755 | end; 1756 | 1757 | procedure TPascalString.FastGetBytes(var output: TBytes); 1758 | begin 1759 | {$IFDEF FPC} 1760 | output := SysUtils.TEncoding.UTF8.GetBytes(Text); 1761 | {$ELSE} 1762 | output := SysUtils.TEncoding.UTF8.GetBytes(buff); 1763 | {$ENDIF} 1764 | end; 1765 | 1766 | function TPascalString.LowerText: SystemString; 1767 | begin 1768 | Result := LowerCase(Text); 1769 | end; 1770 | 1771 | function TPascalString.UpperText: SystemString; 1772 | begin 1773 | Result := UpperCase(Text); 1774 | end; 1775 | 1776 | function TPascalString.Invert: TPascalString; 1777 | var 1778 | i, j: Integer; 1779 | begin 1780 | SetLength(Result.buff, length(buff)); 1781 | j := low(Result.buff); 1782 | for i := high(buff) downto low(buff) do 1783 | begin 1784 | Result.buff[j] := buff[i]; 1785 | inc(j); 1786 | end; 1787 | end; 1788 | 1789 | function TPascalString.TrimChar(const Chars: TPascalString): TPascalString; 1790 | var 1791 | L, bp, EP: Integer; 1792 | begin 1793 | Result := ''; 1794 | L := Len; 1795 | if L > 0 then 1796 | begin 1797 | bp := 1; 1798 | while CharIn(GetChars(bp), @Chars) do 1799 | begin 1800 | inc(bp); 1801 | if (bp > L) then 1802 | begin 1803 | Result := ''; 1804 | Exit; 1805 | end; 1806 | end; 1807 | if bp > L then 1808 | Result := '' 1809 | else 1810 | begin 1811 | EP := L; 1812 | 1813 | while CharIn(GetChars(EP), @Chars) do 1814 | begin 1815 | dec(EP); 1816 | if (EP < 1) then 1817 | begin 1818 | Result := ''; 1819 | Exit; 1820 | end; 1821 | end; 1822 | Result := GetString(bp, EP + 1); 1823 | end; 1824 | end; 1825 | end; 1826 | 1827 | function TPascalString.DeleteChar(const Chars: TPascalString): TPascalString; 1828 | var 1829 | c: SystemChar; 1830 | begin 1831 | Result := ''; 1832 | for c in buff do 1833 | if not CharIn(c, @Chars) then 1834 | Result.Append(c); 1835 | end; 1836 | 1837 | function TPascalString.DeleteChar(const Chars: TOrdChars): TPascalString; 1838 | var 1839 | c: SystemChar; 1840 | begin 1841 | Result := ''; 1842 | for c in buff do 1843 | if not CharIn(c, Chars) then 1844 | Result.Append(c); 1845 | end; 1846 | 1847 | function TPascalString.ReplaceChar(const Chars: TPascalString; const newChar: SystemChar): TPascalString; 1848 | var 1849 | i: Integer; 1850 | begin 1851 | Result.Len := Len; 1852 | for i := low(buff) to high(buff) do 1853 | if CharIn(buff[i], Chars) then 1854 | Result.buff[i] := newChar 1855 | else 1856 | Result.buff[i] := buff[i]; 1857 | end; 1858 | 1859 | function TPascalString.ReplaceChar(const Chars, newChar: SystemChar): TPascalString; 1860 | var 1861 | i: Integer; 1862 | begin 1863 | Result.Len := Len; 1864 | for i := low(buff) to high(buff) do 1865 | if CharIn(buff[i], Chars) then 1866 | Result.buff[i] := newChar 1867 | else 1868 | Result.buff[i] := buff[i]; 1869 | end; 1870 | 1871 | function TPascalString.ReplaceChar(const Chars: TOrdChars; const newChar: SystemChar): TPascalString; 1872 | var 1873 | i: Integer; 1874 | begin 1875 | Result.Len := Len; 1876 | for i := low(buff) to high(buff) do 1877 | if CharIn(buff[i], Chars) then 1878 | Result.buff[i] := newChar 1879 | else 1880 | Result.buff[i] := buff[i]; 1881 | end; 1882 | 1883 | function TPascalString.SmithWaterman(const p: PPascalString): Double; 1884 | begin 1885 | Result := SmithWatermanCompare(@Self, @p); 1886 | end; 1887 | 1888 | function TPascalString.SmithWaterman(const s: TPascalString): Double; 1889 | begin 1890 | Result := SmithWatermanCompare(@Self, @s); 1891 | end; 1892 | 1893 | function TPascalString.BOMBytes: TBytes; 1894 | begin 1895 | {$IFDEF FPC} 1896 | Result := GetBytes; 1897 | {$ELSE} 1898 | Result := SysUtils.TEncoding.UTF8.GetPreamble + GetBytes; 1899 | {$ENDIF} 1900 | end; 1901 | 1902 | initialization 1903 | 1904 | finalization 1905 | 1906 | end. 1907 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # PascalString 2 | 3 | 4 | supports platform Win32, Win64, OSX, iOS and Android. 5 | 6 | 7 | 8 | ## Usage TPascalString 9 | 10 | ```Delphi 11 | 12 | var 13 | s:string; 14 | c:Char; 15 | ps:TPascalString; 16 | i:Integer; 17 | likeness:Double; 18 | diff1, diff2:TPascalString; 19 | begin 20 | ps:='123'; 21 | s:=ps; 22 | ps:=s; 23 | 24 | s:=''; 25 | for i:=1 to ps.len do 26 | s:=s+ps[i]; 27 | 28 | ps:=''; 29 | for c in s do 30 | ps:=ps+c; 31 | 32 | ps.Append('456'); 33 | i:=ps.GetPos('234'); 34 | 35 | //fast Smith–Waterman 36 | ps:='abc123'; 37 | likeness:=ps.SmithWaterman('bc'); 38 | 39 | //Smith–Waterman and out diff 40 | likeness := SmithWatermanCompare('ACAGGT', 'AAGGT', diff1, diff2); 41 | 42 | //long string > 64k support 43 | likeness := SmithWatermanCompareLongString('ACAGGT', 'AAGGT'); 44 | end; 45 | 46 | 47 | ``` 48 | 49 | ### 2018-5-21 50 | 51 | - Added FPC on unicode support: UPascalStrings.pas 52 | - update Parallel core(fpc required package:MultiThreadProcsLaz) 53 | 54 | 55 | ### 2018-3-2 with Smith–Waterman algorithm 56 | 57 | optimized matrix performance 58 | 59 | long string support 60 | 61 | addnew CoreClasses.pas and zDefine.inc unit 62 | 63 | 64 | ### 2018-3-1 65 | 66 | newed Smith–Waterman algorithm 67 | 68 | The Smith–Waterman algorithm performs local sequence alignment; that is, for determining similar regions between two strings of nucleic acid sequences or protein sequences. Instead of looking at the entire sequence, the Smith–Waterman algorithm compares segments of all possible lengths and optimizes the similarity measure. 69 | 70 | The algorithm was first proposed by Temple F. Smith and Michael S. Waterman in 1981.[1] Like the Needleman–Wunsch algorithm, of which it is a variation, Smith–Waterman is a dynamic programming algorithm. As such, it has the desirable property that it is guaranteed to find the optimal local alignment with respect to the scoring system being used (which includes the substitution matrix and the gap-scoring scheme). The main difference to the Needleman–Wunsch algorithm is that negative scoring matrix cells are set to zero, which renders the (thus positively scoring) local alignments visible. Traceback procedure starts at the highest scoring matrix cell and proceeds until a cell with score zero is encountered, yielding the highest scoring local alignment. Because of its cubic computational complexity in time and quadratic complexity in space, it often cannot be practically applied to large-scale problems and is replaced in favor of less general but computationally more efficient alternatives such as (Gotoh, 1982),[2] (Altschul and Erickson, 1986),[3] and (Myers and Miller 1988). 71 | 72 | https://en.wikipedia.org/wiki/Smith%E2%80%93Waterman_algorithm 73 | 74 | 75 | -------------------------------------------------------------------------------- /UPascalStrings.pas: -------------------------------------------------------------------------------- 1 | { ***************************************************************************** } 2 | { * fpc Unicode string support,writen by QQ 600585@qq.com * } 3 | { * https://github.com/PassByYou888/CoreCipher * } 4 | { * https://github.com/PassByYou888/ZServer4D * } 5 | { * https://github.com/PassByYou888/zExpression * } 6 | { * https://github.com/PassByYou888/zTranslate * } 7 | { * https://github.com/PassByYou888/zSound * } 8 | { * https://github.com/PassByYou888/zAnalysis * } 9 | { * https://github.com/PassByYou888/zGameWare * } 10 | { * https://github.com/PassByYou888/zRasterization * } 11 | { ****************************************************************************** } 12 | 13 | unit UPascalStrings; 14 | 15 | {$INCLUDE zDefine.inc} 16 | 17 | interface 18 | 19 | 20 | uses SysUtils, PascalStrings; 21 | 22 | type 23 | {$IFDEF FPC} 24 | USystemChar = UnicodeChar; 25 | USystemString = UnicodeString; 26 | {$ELSE FPC} 27 | USystemChar = PascalStrings.SystemChar; 28 | USystemString = PascalStrings.SystemString; 29 | {$ENDIF FPC} 30 | PUSystemString = ^USystemString; 31 | PUPascalString = ^TUPascalString; 32 | TUArrayChar = array of USystemChar; 33 | TUOrdChar = (uc0to9, uc1to9, uc0to32, uc0to32no10, ucLoAtoF, ucHiAtoF, ucLoAtoZ, ucHiAtoZ, ucHex, ucAtoF, ucAtoZ); 34 | TUOrdChars = set of TUOrdChar; 35 | TUHash = Cardinal; 36 | TUHash64 = UInt64; 37 | 38 | TUPascalString = record 39 | private 40 | function GetText: USystemString; 41 | procedure SetText(const Value: USystemString); 42 | function GetLen: Integer; 43 | procedure SetLen(const Value: Integer); 44 | function GetChars(index: Integer): USystemChar; 45 | procedure SetChars(index: Integer; const Value: USystemChar); 46 | function GetBytes: TBytes; 47 | procedure SetBytes(const Value: TBytes); 48 | function GetLast: USystemChar; 49 | procedure SetLast(const Value: USystemChar); 50 | function GetFirst: USystemChar; 51 | procedure SetFirst(const Value: USystemChar); 52 | public 53 | buff: TUArrayChar; 54 | 55 | {$IFDEF DELPHI} 56 | class operator Equal(const Lhs, Rhs: TUPascalString): Boolean; 57 | class operator NotEqual(const Lhs, Rhs: TUPascalString): Boolean; 58 | class operator GreaterThan(const Lhs, Rhs: TUPascalString): Boolean; 59 | class operator GreaterThanOrEqual(const Lhs, Rhs: TUPascalString): Boolean; 60 | class operator LessThan(const Lhs, Rhs: TUPascalString): Boolean; 61 | class operator LessThanOrEqual(const Lhs, Rhs: TUPascalString): Boolean; 62 | 63 | class operator Add(const Lhs, Rhs: TUPascalString): TUPascalString; 64 | class operator Add(const Lhs: USystemString; const Rhs: TUPascalString): TUPascalString; 65 | class operator Add(const Lhs: TUPascalString; const Rhs: USystemString): TUPascalString; 66 | class operator Add(const Lhs: USystemChar; const Rhs: TUPascalString): TUPascalString; 67 | class operator Add(const Lhs: TUPascalString; const Rhs: USystemChar): TUPascalString; 68 | 69 | class operator Implicit(Value: TPascalString): TUPascalString; 70 | class operator Implicit(Value: Variant): TUPascalString; 71 | class operator Implicit(Value: USystemString): TUPascalString; 72 | class operator Implicit(Value: USystemChar): TUPascalString; 73 | class operator Implicit(Value: TUPascalString): USystemString; 74 | class operator Implicit(Value: TUPascalString): Variant; 75 | 76 | class operator Explicit(Value: TUPascalString): TPascalString; 77 | class operator Explicit(Value: TUPascalString): USystemString; 78 | class operator Explicit(Value: TUPascalString): Variant; 79 | class operator Explicit(Value: USystemString): TUPascalString; 80 | class operator Explicit(Value: Variant): TUPascalString; 81 | class operator Explicit(Value: USystemChar): TUPascalString; 82 | {$ENDIF} 83 | function Copy(index, Count: NativeInt): TUPascalString; 84 | function Same(const p: PUPascalString): Boolean; overload; 85 | function Same(const t: TUPascalString): Boolean; overload; 86 | function Same(const t1, t2: TUPascalString): Boolean; overload; 87 | function Same(const t1, t2, t3: TUPascalString): Boolean; overload; 88 | function Same(const t1, t2, t3, t4: TUPascalString): Boolean; overload; 89 | function Same(const t1, t2, t3, t4, t5: TUPascalString): Boolean; overload; 90 | function Same(const IgnoreCase: Boolean; const t: TUPascalString): Boolean; overload; 91 | function ComparePos(const Offset: Integer; const p: PUPascalString): Boolean; overload; 92 | function ComparePos(const Offset: Integer; const t: TUPascalString): Boolean; overload; 93 | function GetPos(const s: TUPascalString; const Offset: Integer = 1): Integer; overload; 94 | function GetPos(const s: PUPascalString; const Offset: Integer = 1): Integer; overload; 95 | function Exists(c: USystemChar): Boolean; overload; 96 | function Exists(c: array of USystemChar): Boolean; overload; 97 | function Exists(const s: TUPascalString): Boolean; overload; 98 | function GetCharCount(c: USystemChar): Integer; 99 | // 100 | function hash: TUHash; 101 | function Hash64: TUHash64; 102 | // 103 | property Last: USystemChar read GetLast write SetLast; 104 | property First: USystemChar read GetFirst write SetFirst; 105 | 106 | procedure DeleteLast; 107 | procedure DeleteFirst; 108 | procedure Delete(idx, cnt: Integer); 109 | procedure Clear; 110 | procedure Append(t: TUPascalString); overload; 111 | procedure Append(c: USystemChar); overload; 112 | function GetString(bPos, ePos: NativeInt): TUPascalString; 113 | procedure Insert(AText: USystemString; idx: Integer); 114 | // 115 | procedure FastAsText(var output: USystemString); 116 | procedure FastGetBytes(var output: TBytes); 117 | // 118 | property Text: USystemString read GetText write SetText; 119 | function LowerText: USystemString; 120 | function UpperText: USystemString; 121 | function Invert: TUPascalString; 122 | function TrimChar(const Chars: TUPascalString): TUPascalString; 123 | function DeleteChar(const Chars: TUPascalString): TUPascalString; overload; 124 | function DeleteChar(const Chars: TUOrdChars): TUPascalString; overload; 125 | function ReplaceChar(const Chars: TUPascalString; const newChar: USystemChar): TUPascalString; overload; 126 | function ReplaceChar(const Chars, newChar: USystemChar): TUPascalString; overload; 127 | function ReplaceChar(const Chars: TUOrdChars; const newChar: USystemChar): TUPascalString; overload; 128 | 129 | { https://en.wikipedia.org/wiki/Smith%E2%80%93Waterman_algorithm } 130 | function SmithWaterman(const p: PUPascalString): Double; overload; 131 | function SmithWaterman(const s: TUPascalString): Double; overload; 132 | 133 | property Len: Integer read GetLen write SetLen; 134 | property Chars[index: Integer]: USystemChar read GetChars write SetChars; default; 135 | property Bytes: TBytes read GetBytes write SetBytes; 136 | function BOMBytes: TBytes; 137 | end; 138 | 139 | TUArrayPascalString = array of TUPascalString; 140 | PUArrayPascalString = ^TUArrayPascalString; 141 | 142 | TUArrayPascalStringPtr = array of PUPascalString; 143 | PUArrayPascalStringPtr = ^TUArrayPascalStringPtr; 144 | 145 | function UCharIn(c: USystemChar; const SomeChars: array of USystemChar): Boolean; overload; 146 | function UCharIn(c: USystemChar; const SomeChar: USystemChar): Boolean; overload; 147 | function UCharIn(c: USystemChar; const s: TUPascalString): Boolean; overload; 148 | function UCharIn(c: USystemChar; const p: PUPascalString): Boolean; overload; 149 | function UCharIn(c: USystemChar; const SomeCharsets: TUOrdChars): Boolean; overload; 150 | function UCharIn(c: USystemChar; const SomeCharset: TUOrdChar): Boolean; overload; 151 | function UCharIn(c: USystemChar; const SomeCharsets: TUOrdChars; const SomeChars: TUPascalString): Boolean; overload; 152 | function UCharIn(c: USystemChar; const SomeCharsets: TUOrdChars; const p: PUPascalString): Boolean; overload; 153 | 154 | function UFastHashPSystemString(const s: PSystemString): TUHash; overload; 155 | function UFastHash64PSystemString(const s: PSystemString): TUHash64; overload; 156 | 157 | function UFastHashSystemString(const s: SystemString): TUHash; overload; 158 | function UFastHash64SystemString(const s: SystemString): TUHash64; overload; 159 | 160 | function UFastHashPPascalString(const s: PPascalString): TUHash; 161 | function UFastHash64PPascalString(const s: PPascalString): TUHash64; 162 | 163 | function UFormat(const Fmt: USystemString; const Args: array of const): USystemString; 164 | 165 | {$IFDEF FPC} 166 | 167 | operator := (const s: Variant)r: TUPascalString; 168 | operator := (const s: AnsiString)r: TUPascalString; 169 | operator := (const s: UnicodeString)r: TUPascalString; 170 | operator := (const s: WideString)r: TUPascalString; 171 | operator := (const s: ShortString)r: TUPascalString; 172 | operator := (const c: USystemChar)r: TUPascalString; 173 | operator := (const c: TPascalString)r: TUPascalString; 174 | 175 | operator := (const s: TUPascalString)r: AnsiString; 176 | operator := (const s: TUPascalString)r: UnicodeString; 177 | operator := (const s: TUPascalString)r: WideString; 178 | operator := (const s: TUPascalString)r: ShortString; 179 | operator := (const s: TUPascalString)r: Variant; 180 | operator := (const s: TUPascalString)r: TPascalString; 181 | 182 | operator = (const a: TUPascalString; const b: TUPascalString): Boolean; 183 | operator <> (const a: TUPascalString; const b: TUPascalString): Boolean; 184 | operator > (const a: TUPascalString; const b: TUPascalString): Boolean; 185 | operator >= (const a: TUPascalString; const b: TUPascalString): Boolean; 186 | operator < (const a: TUPascalString; const b: TUPascalString): Boolean; 187 | operator <= (const a: TUPascalString; const b: TUPascalString): Boolean; 188 | 189 | operator + (const a: TUPascalString; const b: TUPascalString): TUPascalString; 190 | operator + (const a: TUPascalString; const b: USystemString): TUPascalString; 191 | operator + (const a: USystemString; const b: TUPascalString): TUPascalString; 192 | operator + (const a: TUPascalString; const b: USystemChar): TUPascalString; 193 | operator + (const a: USystemChar; const b: TUPascalString): TUPascalString; 194 | 195 | {$ENDIF} 196 | 197 | { https://en.wikipedia.org/wiki/Smith%E2%80%93Waterman_algorithm } 198 | 199 | // short string likeness and out diff 200 | function USmithWatermanCompare(const seq1, seq2: PUPascalString; var diff1, diff2: TUPascalString; 201 | const NoDiffChar: Boolean; const diffChar: USystemChar): Double; overload; 202 | function USmithWatermanCompare(const seq1, seq2: PUPascalString; var diff1, diff2: TUPascalString): Double; overload; 203 | function USmithWatermanCompare(const seq1, seq2: TUPascalString; var diff1, diff2: TUPascalString; 204 | const NoDiffChar: Boolean; const diffChar: USystemChar): Double; overload; 205 | function USmithWatermanCompare(const seq1, seq2: TUPascalString; var diff1, diff2: TUPascalString): Double; overload; 206 | 207 | // short string likeness 208 | function USmithWatermanCompare(const seq1, seq2: PUPascalString; out Same, Diff: Integer): Double; overload; 209 | function USmithWatermanCompare(const seq1, seq2: PUPascalString): Double; overload; 210 | function USmithWatermanCompare(const seq1, seq2: TUPascalString): Double; overload; 211 | function USmithWatermanCompare(const seq1: TUArrayPascalString; const seq2: TUPascalString): Double; overload; 212 | 213 | // memory likeness 214 | function USmithWatermanCompare(const seq1: Pointer; siz1: Integer; const seq2: Pointer; siz2: Integer; 215 | out Same, Diff: Integer): Double; overload; 216 | function USmithWatermanCompare(const seq1: Pointer; siz1: Integer; const seq2: Pointer; siz2: Integer): Double; overload; 217 | 218 | // long string likeness 219 | function USmithWatermanCompareLongString(const t1, t2: TUPascalString; const MinDiffCharWithPeerLine: Integer; out Same, Diff: Integer): Double; overload; 220 | function USmithWatermanCompareLongString(const t1, t2: TUPascalString): Double; overload; 221 | 222 | var 223 | USystemCharSize: NativeInt = SizeOf(USystemChar); 224 | {$IFDEF CPU64} 225 | UMaxSmithWatermanMatrix: NativeInt = 10000 * 10; 226 | {$ELSE} 227 | UMaxSmithWatermanMatrix: NativeInt = 8192; 228 | {$ENDIF} 229 | 230 | 231 | const 232 | {$IFDEF FirstCharInZero} 233 | UFirstCharPos = 0; 234 | {$ELSE} 235 | UFirstCharPos = 1; 236 | {$ENDIF} 237 | 238 | implementation 239 | 240 | uses CoreClasses, Variants; 241 | 242 | procedure CombineCharsPP(const c1, c2: TUArrayChar; var output: TUArrayChar); 243 | var 244 | LL, rl: Integer; 245 | begin 246 | LL := length(c1); 247 | rl := length(c2); 248 | SetLength(output, LL + rl); 249 | if LL > 0 then 250 | CopyPtr(@c1[0], @output[0], LL * USystemCharSize); 251 | if rl > 0 then 252 | CopyPtr(@c2[0], @output[LL], rl * USystemCharSize); 253 | end; 254 | 255 | procedure CombineCharsSP(const c1: USystemString; const c2: TUArrayChar; var output: TUArrayChar); 256 | var 257 | LL, rl: Integer; 258 | begin 259 | LL := length(c1); 260 | rl := length(c2); 261 | SetLength(output, LL + rl); 262 | if LL > 0 then 263 | CopyPtr(@c1[UFirstCharPos], @output[0], LL * USystemCharSize); 264 | if rl > 0 then 265 | CopyPtr(@c2[0], @output[LL], rl * USystemCharSize); 266 | end; 267 | 268 | procedure CombineCharsPS(const c1: TUArrayChar; const c2: USystemString; var output: TUArrayChar); 269 | var 270 | LL, rl: Integer; 271 | begin 272 | LL := length(c1); 273 | rl := length(c2); 274 | SetLength(output, LL + rl); 275 | if LL > 0 then 276 | CopyPtr(@c1[0], @output[0], LL * USystemCharSize); 277 | if rl > 0 then 278 | CopyPtr(@c2[UFirstCharPos], @output[LL], rl * USystemCharSize); 279 | end; 280 | 281 | procedure CombineCharsCP(const c1: USystemChar; const c2: TUArrayChar; var output: TUArrayChar); 282 | var 283 | rl: Integer; 284 | begin 285 | rl := length(c2); 286 | SetLength(output, rl + 1); 287 | output[0] := c1; 288 | if rl > 0 then 289 | CopyPtr(@c2[0], @output[1], rl * USystemCharSize); 290 | end; 291 | 292 | procedure CombineCharsPC(const c1: TUArrayChar; const c2: USystemChar; var output: TUArrayChar); 293 | var 294 | LL: Integer; 295 | begin 296 | LL := length(c1); 297 | SetLength(output, LL + 1); 298 | if LL > 0 then 299 | CopyPtr(@c1[0], @output[0], LL * USystemCharSize); 300 | output[LL] := c2; 301 | end; 302 | 303 | function UCharIn(c: USystemChar; const SomeChars: array of USystemChar): Boolean; 304 | var 305 | AChar: USystemChar; 306 | begin 307 | Result := True; 308 | for AChar in SomeChars do 309 | if AChar = c then 310 | Exit; 311 | Result := False; 312 | end; 313 | 314 | function UCharIn(c: USystemChar; const SomeChar: USystemChar): Boolean; 315 | begin 316 | Result := c = SomeChar; 317 | end; 318 | 319 | function UCharIn(c: USystemChar; const s: TUPascalString): Boolean; 320 | begin 321 | Result := s.Exists(c); 322 | end; 323 | 324 | function UCharIn(c: USystemChar; const p: PUPascalString): Boolean; 325 | begin 326 | Result := p^.Exists(c); 327 | end; 328 | 329 | function UCharIn(c: USystemChar; const SomeCharset: TUOrdChar): Boolean; 330 | const 331 | ord0 = Ord('0'); 332 | ord1 = Ord('1'); 333 | ord9 = Ord('9'); 334 | ordLA = Ord('a'); 335 | ordHA = Ord('A'); 336 | ordLF = Ord('f'); 337 | ordHF = Ord('F'); 338 | ordLZ = Ord('z'); 339 | ordHZ = Ord('Z'); 340 | 341 | var 342 | v: Word; 343 | begin 344 | v := Ord(c); 345 | case SomeCharset of 346 | uc0to9: Result := (v >= ord0) and (v <= ord9); 347 | uc1to9: Result := (v >= ord1) and (v <= ord9); 348 | uc0to32: Result := ((v >= 0) and (v <= 32)); 349 | uc0to32no10: Result := ((v >= 0) and (v <= 32) and (v <> 10)); 350 | ucLoAtoF: Result := (v >= ordLA) and (v <= ordLF); 351 | ucHiAtoF: Result := (v >= ordHA) and (v <= ordHF); 352 | ucLoAtoZ: Result := (v >= ordLA) and (v <= ordLZ); 353 | ucHiAtoZ: Result := (v >= ordHA) and (v <= ordHZ); 354 | ucHex: Result := ((v >= ordLA) and (v <= ordLF)) or ((v >= ordHA) and (v <= ordHF)) or ((v >= ord0) and (v <= ord9)); 355 | ucAtoF: Result := ((v >= ordLA) and (v <= ordLF)) or ((v >= ordHA) and (v <= ordHF)); 356 | ucAtoZ: Result := ((v >= ordLA) and (v <= ordLZ)) or ((v >= ordHA) and (v <= ordHZ)); 357 | else Result := False; 358 | end; 359 | end; 360 | 361 | function UCharIn(c: USystemChar; const SomeCharsets: TUOrdChars): Boolean; 362 | var 363 | i: TUOrdChar; 364 | begin 365 | Result := True; 366 | for i in SomeCharsets do 367 | if UCharIn(c, i) then 368 | Exit; 369 | Result := False; 370 | end; 371 | 372 | function UCharIn(c: USystemChar; const SomeCharsets: TUOrdChars; const SomeChars: TUPascalString): Boolean; 373 | begin 374 | if UCharIn(c, SomeCharsets) then 375 | Result := True 376 | else 377 | Result := UCharIn(c, SomeChars); 378 | end; 379 | 380 | function UCharIn(c: USystemChar; const SomeCharsets: TUOrdChars; const p: PUPascalString): Boolean; 381 | begin 382 | if UCharIn(c, SomeCharsets) then 383 | Result := True 384 | else 385 | Result := UCharIn(c, p); 386 | end; 387 | 388 | function UFastHashPSystemString(const s: PSystemString): TUHash; 389 | var 390 | i: Integer; 391 | c: USystemChar; 392 | begin 393 | Result := 0; 394 | 395 | {$IFDEF FirstCharInZero} 396 | for i := 0 to length(s^) - 1 do 397 | {$ELSE} 398 | for i := 1 to length(s^) do 399 | {$ENDIF} 400 | begin 401 | c := s^[i]; 402 | if UCharIn(c, ucHiAtoZ) then 403 | inc(c, 32); 404 | Result := ((Result shl 7) or (Result shr 25)) + TUHash(c); 405 | end; 406 | end; 407 | 408 | function UFastHash64PSystemString(const s: PSystemString): TUHash64; 409 | var 410 | i: Integer; 411 | c: USystemChar; 412 | begin 413 | Result := 0; 414 | 415 | {$IFDEF FirstCharInZero} 416 | for i := 0 to length(s^) - 1 do 417 | {$ELSE} 418 | for i := 1 to length(s^) do 419 | {$ENDIF} 420 | begin 421 | c := s^[i]; 422 | if UCharIn(c, ucHiAtoZ) then 423 | inc(c, 32); 424 | Result := ((Result shl 7) or (Result shr 57)) + TUHash64(c); 425 | end; 426 | end; 427 | 428 | function UFastHashSystemString(const s: SystemString): TUHash; 429 | begin 430 | Result := UFastHashPSystemString(@s); 431 | end; 432 | 433 | function UFastHash64SystemString(const s: SystemString): TUHash64; 434 | begin 435 | Result := UFastHash64PSystemString(@s); 436 | end; 437 | 438 | function UFastHashPPascalString(const s: PPascalString): TUHash; 439 | var 440 | i: Integer; 441 | c: USystemChar; 442 | begin 443 | Result := 0; 444 | for i := 1 to s^.Len do 445 | begin 446 | c := s^[i]; 447 | if UCharIn(c, ucHiAtoZ) then 448 | inc(c, 32); 449 | Result := ((Result shl 7) or (Result shr 25)) + TUHash(c); 450 | end; 451 | end; 452 | 453 | function UFastHash64PPascalString(const s: PPascalString): TUHash64; 454 | var 455 | i: Integer; 456 | c: USystemChar; 457 | begin 458 | Result := 0; 459 | for i := 1 to s^.Len do 460 | begin 461 | c := s^[i]; 462 | if UCharIn(c, ucHiAtoZ) then 463 | inc(c, 32); 464 | Result := ((Result shl 7) or (Result shr 57)) + TUHash64(c); 465 | end; 466 | end; 467 | 468 | function UFormat(const Fmt: USystemString; const Args: array of const): USystemString; 469 | begin 470 | {$IFDEF FPC} 471 | Result := UnicodeFormat(Fmt, Args); 472 | {$ELSE FPC} 473 | Result := Format(Fmt, Args); 474 | {$ENDIF FPC} 475 | end; 476 | 477 | function BytesOfPascalString(const s: TUPascalString): TBytes; 478 | begin 479 | Result := s.Bytes; 480 | end; 481 | 482 | function PascalStringOfBytes(const s: TBytes): TUPascalString; 483 | begin 484 | Result.Bytes := s; 485 | end; 486 | 487 | function GetSWMVMemory(const xLen, yLen: NativeInt): Pointer; inline; 488 | { optimized matrix performance } 489 | begin 490 | Result := System.AllocMem((xLen + 1) * (yLen + 1) * SizeOf(NativeInt)); 491 | end; 492 | 493 | function GetSWMV(const p: Pointer; const w, x, y: NativeInt): NativeInt; inline; 494 | { optimized matrix performance } 495 | begin 496 | Result := PNativeInt(nativeUInt(p) + ((x + y * (w + 1)) * SizeOf(NativeInt)))^; 497 | end; 498 | 499 | procedure SetSWMV(const p: Pointer; const w, x, y: NativeInt; const v: NativeInt); inline; 500 | { optimized matrix performance } 501 | begin 502 | PNativeInt(nativeUInt(p) + ((x + y * (w + 1)) * SizeOf(NativeInt)))^ := v; 503 | end; 504 | 505 | function GetMax(const i1, i2: NativeInt): NativeInt; inline; 506 | begin 507 | if i1 > i2 then 508 | Result := i1 509 | else 510 | Result := i2; 511 | end; 512 | 513 | const 514 | SmithWaterman_MatchOk = 1; 515 | mismatch_penalty = -1; 516 | gap_penalty = -1; 517 | 518 | function USmithWatermanCompare(const seq1, seq2: PUPascalString; var diff1, diff2: TUPascalString; 519 | const NoDiffChar: Boolean; const diffChar: USystemChar): Double; 520 | 521 | function InlineMatch(alphaC, betaC: USystemChar; const diffC: USystemChar): Integer; inline; 522 | begin 523 | if UCharIn(alphaC, ucLoAtoZ) then 524 | dec(alphaC, 32); 525 | if UCharIn(betaC, ucLoAtoZ) then 526 | dec(betaC, 32); 527 | 528 | if alphaC = betaC then 529 | Result := SmithWaterman_MatchOk 530 | else if (alphaC = diffC) or (betaC = diffC) then 531 | Result := gap_penalty 532 | else 533 | Result := mismatch_penalty; 534 | end; 535 | 536 | var 537 | swMatrixPtr: Pointer; 538 | i, j, L1, l2: NativeInt; 539 | matched, deleted, inserted: NativeInt; 540 | score_current, score_diagonal, score_left, score_right: NativeInt; 541 | identity: NativeInt; 542 | align1, align2: TUPascalString; 543 | begin 544 | L1 := seq1^.Len; 545 | l2 := seq2^.Len; 546 | 547 | if (L1 = 0) or (l2 = 0) or (L1 > UMaxSmithWatermanMatrix) or (l2 > UMaxSmithWatermanMatrix) then 548 | begin 549 | Result := -1; 550 | Exit; 551 | end; 552 | 553 | { fast build matrix } 554 | swMatrixPtr := GetSWMVMemory(L1, l2); 555 | if swMatrixPtr = nil then 556 | begin 557 | diff1 := ''; 558 | diff2 := ''; 559 | Result := -1; 560 | Exit; 561 | end; 562 | 563 | i := 0; 564 | while i <= L1 do 565 | begin 566 | SetSWMV(swMatrixPtr, L1, i, 0, gap_penalty * i); 567 | inc(i); 568 | end; 569 | 570 | j := 0; 571 | while j <= l2 do 572 | begin 573 | SetSWMV(swMatrixPtr, L1, 0, j, gap_penalty * j); 574 | inc(j); 575 | end; 576 | 577 | { compute matrix } 578 | i := 1; 579 | while i <= L1 do 580 | begin 581 | j := 1; 582 | while j <= l2 do 583 | begin 584 | matched := GetSWMV(swMatrixPtr, L1, i - 1, j - 1) + InlineMatch(seq1^[i], seq2^[j], diffChar); 585 | deleted := GetSWMV(swMatrixPtr, L1, i - 1, j) + gap_penalty; 586 | inserted := GetSWMV(swMatrixPtr, L1, i, j - 1) + gap_penalty; 587 | SetSWMV(swMatrixPtr, L1, i, j, GetMax(matched, GetMax(deleted, inserted))); 588 | inc(j); 589 | end; 590 | inc(i); 591 | end; 592 | 593 | { compute align } 594 | i := L1; 595 | j := l2; 596 | align1 := ''; 597 | align2 := ''; 598 | identity := 0; 599 | while (i > 0) and (j > 0) do 600 | begin 601 | score_current := GetSWMV(swMatrixPtr, L1, i, j); 602 | score_diagonal := GetSWMV(swMatrixPtr, L1, i - 1, j - 1); 603 | score_left := GetSWMV(swMatrixPtr, L1, i - 1, j); 604 | score_right := GetSWMV(swMatrixPtr, L1, i, j - 1); 605 | 606 | matched := InlineMatch(seq1^[i], seq2^[j], diffChar); 607 | 608 | if score_current = score_diagonal + matched then 609 | begin 610 | if matched = SmithWaterman_MatchOk then 611 | begin 612 | inc(identity); 613 | align1.Append(seq1^[i]); 614 | align2.Append(seq2^[j]); 615 | end 616 | else if NoDiffChar then 617 | begin 618 | align1.Append(diffChar); 619 | align2.Append(diffChar); 620 | end 621 | else 622 | begin 623 | align1.Append(seq1^[i]); 624 | align2.Append(seq2^[j]); 625 | end; 626 | dec(i); 627 | dec(j); 628 | end 629 | else if score_current = score_left + gap_penalty then 630 | begin 631 | if NoDiffChar then 632 | align1.Append(diffChar) 633 | else 634 | align1.Append(seq1^[i]); 635 | align2.Append(diffChar); 636 | dec(i); 637 | end 638 | else if score_current = score_right + gap_penalty then 639 | begin 640 | if NoDiffChar then 641 | align2.Append(diffChar) 642 | else 643 | align2.Append(seq2^[j]); 644 | align1.Append(diffChar); 645 | dec(j); 646 | end 647 | else 648 | raise Exception.Create('matrix error'); // matrix debug time 649 | end; 650 | 651 | System.FreeMemory(swMatrixPtr); 652 | 653 | while i > 0 do 654 | begin 655 | if NoDiffChar then 656 | align1.Append(diffChar) 657 | else 658 | align1.Append(seq1^[i]); 659 | align2.Append(diffChar); 660 | dec(i); 661 | end; 662 | 663 | while j > 0 do 664 | begin 665 | if NoDiffChar then 666 | align2.Append(diffChar) 667 | else 668 | align2.Append(seq2^[j]); 669 | align1.Append(diffChar); 670 | dec(j); 671 | end; 672 | 673 | if identity > 0 then 674 | Result := identity / align1.Len 675 | else 676 | Result := -1; 677 | 678 | diff1 := align1.Invert; 679 | diff2 := align2.Invert; 680 | end; 681 | 682 | function USmithWatermanCompare(const seq1, seq2: PUPascalString; var diff1, diff2: TUPascalString): Double; 683 | begin 684 | Result := USmithWatermanCompare(seq1, seq2, diff1, diff2, False, '-'); 685 | end; 686 | 687 | function USmithWatermanCompare(const seq1, seq2: TUPascalString; var diff1, diff2: TUPascalString; 688 | const NoDiffChar: Boolean; const diffChar: USystemChar): Double; 689 | begin 690 | Result := USmithWatermanCompare(@seq1, @seq2, diff1, diff2, NoDiffChar, diffChar); 691 | end; 692 | 693 | function USmithWatermanCompare(const seq1, seq2: TUPascalString; var diff1, diff2: TUPascalString): Double; 694 | begin 695 | Result := USmithWatermanCompare(seq1, seq2, diff1, diff2, False, '-'); 696 | end; 697 | 698 | function USmithWatermanCompare(const seq1, seq2: PUPascalString; out Same, Diff: Integer): Double; 699 | 700 | function InlineMatch(alphaC, betaC: USystemChar): NativeInt; inline; 701 | begin 702 | if UCharIn(alphaC, ucLoAtoZ) then 703 | dec(alphaC, 32); 704 | if UCharIn(betaC, ucLoAtoZ) then 705 | dec(betaC, 32); 706 | 707 | if alphaC = betaC then 708 | Result := SmithWaterman_MatchOk 709 | else 710 | Result := mismatch_penalty; 711 | end; 712 | 713 | var 714 | swMatrixPtr: Pointer; 715 | i, j, L1, l2: NativeInt; 716 | matched, deleted, inserted: NativeInt; 717 | score_current, score_diagonal, score_left, score_right: NativeInt; 718 | identity, L: NativeInt; 719 | begin 720 | L1 := seq1^.Len; 721 | l2 := seq2^.Len; 722 | 723 | if (L1 = 0) or (l2 = 0) or (L1 > UMaxSmithWatermanMatrix) or (l2 > UMaxSmithWatermanMatrix) then 724 | begin 725 | Result := -1; 726 | Same := 0; 727 | Diff := L1 + l2; 728 | Exit; 729 | end; 730 | 731 | { fast build matrix } 732 | swMatrixPtr := GetSWMVMemory(L1, l2); 733 | if swMatrixPtr = nil then 734 | begin 735 | Result := -1; 736 | Exit; 737 | end; 738 | 739 | i := 0; 740 | while i <= L1 do 741 | begin 742 | SetSWMV(swMatrixPtr, L1, i, 0, gap_penalty * i); 743 | inc(i); 744 | end; 745 | 746 | j := 0; 747 | while j <= l2 do 748 | begin 749 | SetSWMV(swMatrixPtr, L1, 0, j, gap_penalty * j); 750 | inc(j); 751 | end; 752 | 753 | { compute matrix } 754 | i := 1; 755 | while i <= L1 do 756 | begin 757 | j := 1; 758 | while j <= l2 do 759 | begin 760 | matched := GetSWMV(swMatrixPtr, L1, i - 1, j - 1) + InlineMatch(seq1^[i], seq2^[j]); 761 | deleted := GetSWMV(swMatrixPtr, L1, i - 1, j) + gap_penalty; 762 | inserted := GetSWMV(swMatrixPtr, L1, i, j - 1) + gap_penalty; 763 | SetSWMV(swMatrixPtr, L1, i, j, GetMax(matched, GetMax(deleted, inserted))); 764 | inc(j); 765 | end; 766 | inc(i); 767 | end; 768 | 769 | { compute align } 770 | i := L1; 771 | j := l2; 772 | identity := 0; 773 | L := 0; 774 | while (i > 0) and (j > 0) do 775 | begin 776 | score_current := GetSWMV(swMatrixPtr, L1, i, j); 777 | score_diagonal := GetSWMV(swMatrixPtr, L1, i - 1, j - 1); 778 | score_left := GetSWMV(swMatrixPtr, L1, i - 1, j); 779 | score_right := GetSWMV(swMatrixPtr, L1, i, j - 1); 780 | matched := InlineMatch(seq1^[i], seq2^[j]); 781 | 782 | if score_current = score_diagonal + matched then 783 | begin 784 | if matched = SmithWaterman_MatchOk then 785 | inc(identity); 786 | 787 | inc(L); 788 | dec(i); 789 | dec(j); 790 | end 791 | else if score_current = score_left + gap_penalty then 792 | begin 793 | inc(L); 794 | dec(i); 795 | end 796 | else if score_current = score_right + gap_penalty then 797 | begin 798 | inc(L); 799 | dec(j); 800 | end 801 | else 802 | raise Exception.Create('matrix error'); // matrix debug time 803 | end; 804 | 805 | System.FreeMemory(swMatrixPtr); 806 | 807 | if identity > 0 then 808 | begin 809 | Result := identity / (L + i + j); 810 | Same := identity; 811 | Diff := (L + i + j) - identity; 812 | end 813 | else 814 | begin 815 | Result := -1; 816 | Same := 0; 817 | Diff := L + i + j; 818 | end; 819 | end; 820 | 821 | function USmithWatermanCompare(const seq1, seq2: PUPascalString): Double; 822 | var 823 | Same, Diff: Integer; 824 | begin 825 | Result := USmithWatermanCompare(seq1, seq2, Same, Diff); 826 | end; 827 | 828 | function USmithWatermanCompare(const seq1, seq2: TUPascalString): Double; 829 | begin 830 | Result := USmithWatermanCompare(@seq1, @seq2); 831 | end; 832 | 833 | function USmithWatermanCompare(const seq1: TUArrayPascalString; const seq2: TUPascalString): Double; 834 | var 835 | i: Integer; 836 | r: Double; 837 | begin 838 | Result := -1; 839 | for i := 0 to length(seq1) - 1 do 840 | begin 841 | r := USmithWatermanCompare(seq1[i], seq2); 842 | if r > Result then 843 | Result := r; 844 | end; 845 | end; 846 | 847 | function USmithWatermanCompare(const seq1: Pointer; siz1: Integer; const seq2: Pointer; siz2: Integer; 848 | out Same, Diff: Integer): Double; 849 | 850 | function InlineMatch(const alphaB, betaB: Byte): NativeInt; inline; 851 | begin 852 | if alphaB = betaB then 853 | Result := SmithWaterman_MatchOk 854 | else 855 | Result := mismatch_penalty; 856 | end; 857 | 858 | var 859 | swMatrixPtr: Pointer; 860 | i, j, L1, l2: NativeInt; 861 | matched, deleted, inserted: NativeInt; 862 | score_current, score_diagonal, score_left, score_right: NativeInt; 863 | identity, L: NativeInt; 864 | begin 865 | L1 := siz1; 866 | l2 := siz2; 867 | 868 | if (L1 = 0) or (l2 = 0) or (L1 > UMaxSmithWatermanMatrix) or (l2 > UMaxSmithWatermanMatrix) then 869 | begin 870 | Result := -1; 871 | Same := 0; 872 | Diff := L1 + l2; 873 | Exit; 874 | end; 875 | 876 | { fast build matrix } 877 | swMatrixPtr := GetSWMVMemory(L1, l2); 878 | if swMatrixPtr = nil then 879 | begin 880 | Result := -1; 881 | Exit; 882 | end; 883 | 884 | i := 0; 885 | while i <= L1 do 886 | begin 887 | SetSWMV(swMatrixPtr, L1, i, 0, gap_penalty * i); 888 | inc(i); 889 | end; 890 | 891 | j := 0; 892 | while j <= l2 do 893 | begin 894 | SetSWMV(swMatrixPtr, L1, 0, j, gap_penalty * j); 895 | inc(j); 896 | end; 897 | 898 | { compute matrix } 899 | i := 1; 900 | while i <= L1 do 901 | begin 902 | j := 1; 903 | while j <= l2 do 904 | begin 905 | matched := GetSWMV(swMatrixPtr, L1, i - 1, j - 1) + InlineMatch(PByte(nativeUInt(seq1) + (i - 1))^, PByte(nativeUInt(seq2) + (j - 1))^); 906 | deleted := GetSWMV(swMatrixPtr, L1, i - 1, j) + gap_penalty; 907 | inserted := GetSWMV(swMatrixPtr, L1, i, j - 1) + gap_penalty; 908 | SetSWMV(swMatrixPtr, L1, i, j, GetMax(matched, GetMax(deleted, inserted))); 909 | inc(j); 910 | end; 911 | inc(i); 912 | end; 913 | 914 | { compute align } 915 | i := L1; 916 | j := l2; 917 | identity := 0; 918 | L := 0; 919 | while (i > 0) and (j > 0) do 920 | begin 921 | score_current := GetSWMV(swMatrixPtr, L1, i, j); 922 | score_diagonal := GetSWMV(swMatrixPtr, L1, i - 1, j - 1); 923 | score_left := GetSWMV(swMatrixPtr, L1, i - 1, j); 924 | score_right := GetSWMV(swMatrixPtr, L1, i, j - 1); 925 | matched := InlineMatch(PByte(nativeUInt(seq1) + (i - 1))^, PByte(nativeUInt(seq2) + (j - 1))^); 926 | 927 | if score_current = score_diagonal + matched then 928 | begin 929 | if matched = SmithWaterman_MatchOk then 930 | inc(identity); 931 | 932 | inc(L); 933 | dec(i); 934 | dec(j); 935 | end 936 | else if score_current = score_left + gap_penalty then 937 | begin 938 | inc(L); 939 | dec(i); 940 | end 941 | else if score_current = score_right + gap_penalty then 942 | begin 943 | inc(L); 944 | dec(j); 945 | end 946 | else 947 | raise Exception.Create('matrix error'); // matrix debug time 948 | end; 949 | 950 | System.FreeMemory(swMatrixPtr); 951 | 952 | if identity > 0 then 953 | begin 954 | Result := identity / (L + i + j); 955 | Same := identity; 956 | Diff := (L + i + j) - identity; 957 | end 958 | else 959 | begin 960 | Result := -1; 961 | Same := 0; 962 | Diff := L + i + j; 963 | end; 964 | end; 965 | 966 | function USmithWatermanCompare(const seq1: Pointer; siz1: Integer; const seq2: Pointer; siz2: Integer): Double; 967 | var 968 | Same, Diff: Integer; 969 | begin 970 | Result := USmithWatermanCompare(seq1, siz1, seq2, siz2, Same, Diff); 971 | end; 972 | 973 | function USmithWatermanCompareLongString(const t1, t2: TUPascalString; const MinDiffCharWithPeerLine: Integer; out Same, Diff: Integer): Double; 974 | type 975 | PSRec = ^TSRec; 976 | 977 | TSRec = record 978 | s: TUPascalString; 979 | end; 980 | 981 | procedure _FillText(psPtr: PUPascalString; outLst: TCoreClassList); 982 | var 983 | L, i: Integer; 984 | n: TUPascalString; 985 | p: PSRec; 986 | begin 987 | L := psPtr^.Len; 988 | i := 1; 989 | n := ''; 990 | while i <= L do 991 | begin 992 | if UCharIn(psPtr^[i], [#13, #10]) then 993 | begin 994 | n := n.DeleteChar(#32#9); 995 | if n.Len > 0 then 996 | begin 997 | new(p); 998 | p^.s := n; 999 | outLst.Add(p); 1000 | n := ''; 1001 | end; 1002 | repeat 1003 | inc(i); 1004 | until (i > L) or (not UCharIn(psPtr^[i], [#13, #10, #32, #9])); 1005 | end 1006 | else 1007 | begin 1008 | n.Append(psPtr^[i]); 1009 | inc(i); 1010 | end; 1011 | end; 1012 | 1013 | n := n.DeleteChar(#32#9); 1014 | if n.Len > 0 then 1015 | begin 1016 | new(p); 1017 | p^.s := n; 1018 | outLst.Add(p); 1019 | end; 1020 | end; 1021 | 1022 | function InlineMatch(const alpha, beta: PSRec; const MinDiffCharWithPeerLine: Integer; var cSame, cDiff: Integer): NativeInt; inline; 1023 | begin 1024 | if USmithWatermanCompare(@alpha^.s, @beta^.s, cSame, cDiff) > 0 then 1025 | begin 1026 | if cDiff < MinDiffCharWithPeerLine then 1027 | Result := SmithWaterman_MatchOk 1028 | else 1029 | Result := mismatch_penalty; 1030 | end 1031 | else 1032 | Result := mismatch_penalty; 1033 | end; 1034 | 1035 | var 1036 | lst1, lst2: TCoreClassList; 1037 | 1038 | procedure _Init; 1039 | begin 1040 | lst1 := TCoreClassList.Create; 1041 | lst2 := TCoreClassList.Create; 1042 | _FillText(@t1, lst1); 1043 | _FillText(@t2, lst2); 1044 | end; 1045 | 1046 | procedure _Free; 1047 | var 1048 | i: Integer; 1049 | begin 1050 | for i := 0 to lst1.Count - 1 do 1051 | Dispose(PSRec(lst1[i])); 1052 | for i := 0 to lst2.Count - 1 do 1053 | Dispose(PSRec(lst2[i])); 1054 | DisposeObject([lst1, lst2]); 1055 | end; 1056 | 1057 | var 1058 | swMatrixPtr: Pointer; 1059 | i, j, L1, l2: NativeInt; 1060 | matched, deleted, inserted: NativeInt; 1061 | score_current, score_diagonal, score_left, score_right: NativeInt; 1062 | cSame, cDiff, TotalSame, TotalDiff: Integer; 1063 | begin 1064 | _Init; 1065 | L1 := lst1.Count; 1066 | l2 := lst2.Count; 1067 | 1068 | if (L1 = 0) or (l2 = 0) or (L1 > UMaxSmithWatermanMatrix) or (l2 > UMaxSmithWatermanMatrix) then 1069 | begin 1070 | Result := -1; 1071 | Same := 0; 1072 | Diff := L1 + l2; 1073 | _Free; 1074 | Exit; 1075 | end; 1076 | 1077 | { fast build matrix } 1078 | swMatrixPtr := GetSWMVMemory(L1, l2); 1079 | if swMatrixPtr = nil then 1080 | begin 1081 | Result := -1; 1082 | _Free; 1083 | Exit; 1084 | end; 1085 | 1086 | i := 0; 1087 | while i <= L1 do 1088 | begin 1089 | SetSWMV(swMatrixPtr, L1, i, 0, gap_penalty * i); 1090 | inc(i); 1091 | end; 1092 | 1093 | j := 0; 1094 | while j <= l2 do 1095 | begin 1096 | SetSWMV(swMatrixPtr, L1, 0, j, gap_penalty * j); 1097 | inc(j); 1098 | end; 1099 | 1100 | { compute matrix } 1101 | i := 1; 1102 | while i <= L1 do 1103 | begin 1104 | j := 1; 1105 | while j <= l2 do 1106 | begin 1107 | matched := GetSWMV(swMatrixPtr, L1, i - 1, j - 1) + InlineMatch(PSRec(lst1[i - 1]), PSRec(lst2[j - 1]), MinDiffCharWithPeerLine, cSame, cDiff); 1108 | deleted := GetSWMV(swMatrixPtr, L1, i - 1, j) + gap_penalty; 1109 | inserted := GetSWMV(swMatrixPtr, L1, i, j - 1) + gap_penalty; 1110 | SetSWMV(swMatrixPtr, L1, i, j, GetMax(matched, GetMax(deleted, inserted))); 1111 | inc(j); 1112 | end; 1113 | inc(i); 1114 | end; 1115 | 1116 | { compute align } 1117 | i := L1; 1118 | j := l2; 1119 | TotalSame := 0; 1120 | TotalDiff := 0; 1121 | while (i > 0) and (j > 0) do 1122 | begin 1123 | score_current := GetSWMV(swMatrixPtr, L1, i, j); 1124 | score_diagonal := GetSWMV(swMatrixPtr, L1, i - 1, j - 1); 1125 | score_left := GetSWMV(swMatrixPtr, L1, i - 1, j); 1126 | score_right := GetSWMV(swMatrixPtr, L1, i, j - 1); 1127 | matched := InlineMatch(PSRec(lst1[i - 1]), PSRec(lst2[j - 1]), MinDiffCharWithPeerLine, cSame, cDiff); 1128 | 1129 | inc(TotalSame, cSame); 1130 | inc(TotalDiff, cDiff); 1131 | 1132 | if score_current = score_diagonal + matched then 1133 | begin 1134 | dec(i); 1135 | dec(j); 1136 | end 1137 | else if score_current = score_left + gap_penalty then 1138 | begin 1139 | dec(i); 1140 | end 1141 | else if score_current = score_right + gap_penalty then 1142 | begin 1143 | dec(j); 1144 | end 1145 | else 1146 | raise Exception.Create('matrix error'); // matrix debug time 1147 | end; 1148 | 1149 | System.FreeMemory(swMatrixPtr); 1150 | _Free; 1151 | 1152 | if TotalSame > 0 then 1153 | begin 1154 | Result := TotalSame / (TotalSame + TotalDiff); 1155 | Same := TotalSame; 1156 | Diff := TotalDiff; 1157 | end 1158 | else 1159 | begin 1160 | Result := -1; 1161 | Same := 0; 1162 | Diff := t2.Len + t1.Len; 1163 | end; 1164 | end; 1165 | 1166 | function USmithWatermanCompareLongString(const t1, t2: TUPascalString): Double; 1167 | var 1168 | Same, Diff: Integer; 1169 | begin 1170 | Result := USmithWatermanCompareLongString(t1, t2, 5, Same, Diff); 1171 | end; 1172 | 1173 | {$IFDEF FPC} 1174 | 1175 | 1176 | operator := (const s: Variant)r: TUPascalString; 1177 | begin 1178 | r.Text := s; 1179 | end; 1180 | 1181 | operator := (const s: AnsiString)r: TUPascalString; 1182 | begin 1183 | r.Text := s; 1184 | end; 1185 | 1186 | operator := (const s: UnicodeString)r: TUPascalString; 1187 | begin 1188 | r.Text := s; 1189 | end; 1190 | 1191 | operator := (const s: WideString)r: TUPascalString; 1192 | begin 1193 | r.Text := s; 1194 | end; 1195 | 1196 | operator := (const s: ShortString)r: TUPascalString; 1197 | begin 1198 | r.Text := s; 1199 | end; 1200 | 1201 | operator := (const c: USystemChar)r: TUPascalString; 1202 | begin 1203 | r.Text := c; 1204 | end; 1205 | 1206 | operator := (const c: TPascalString)r: TUPascalString; 1207 | begin 1208 | Result.Bytes := c.Bytes; 1209 | end; 1210 | 1211 | operator := (const s: TUPascalString)r: AnsiString; 1212 | begin 1213 | r := s.Text; 1214 | end; 1215 | 1216 | operator := (const s: TUPascalString)r: UnicodeString; 1217 | begin 1218 | r := s.Text; 1219 | end; 1220 | 1221 | operator := (const s: TUPascalString)r: WideString; 1222 | begin 1223 | r := s.Text; 1224 | end; 1225 | 1226 | operator := (const s: TUPascalString)r: ShortString; 1227 | begin 1228 | r := s.Text; 1229 | end; 1230 | 1231 | operator := (const s: TUPascalString)r: Variant; 1232 | begin 1233 | r := s.Text; 1234 | end; 1235 | 1236 | operator := (const s: TUPascalString)r: TPascalString; 1237 | begin 1238 | Result.Bytes := s.Bytes; 1239 | end; 1240 | 1241 | operator = (const a: TUPascalString; const b: TUPascalString): Boolean; 1242 | begin 1243 | Result := a.Text = b.Text; 1244 | end; 1245 | 1246 | operator <> (const a: TUPascalString; const b: TUPascalString): Boolean; 1247 | begin 1248 | Result := a.Text <> b.Text; 1249 | end; 1250 | 1251 | operator > (const a: TUPascalString; const b: TUPascalString): Boolean; 1252 | begin 1253 | Result := a.Text > b.Text; 1254 | end; 1255 | 1256 | operator >= (const a: TUPascalString; const b: TUPascalString): Boolean; 1257 | begin 1258 | Result := a.Text >= b.Text; 1259 | end; 1260 | 1261 | operator < (const a: TUPascalString; const b: TUPascalString): Boolean; 1262 | begin 1263 | Result := a.Text < b.Text; 1264 | end; 1265 | 1266 | operator <= (const a: TUPascalString; const b: TUPascalString): Boolean; 1267 | begin 1268 | Result := a.Text <= b.Text; 1269 | end; 1270 | 1271 | operator + (const a: TUPascalString; const b: TUPascalString): TUPascalString; 1272 | begin 1273 | CombineCharsPP(a.buff, b.buff, Result.buff); 1274 | end; 1275 | 1276 | operator + (const a: TUPascalString; const b: USystemString): TUPascalString; 1277 | begin 1278 | CombineCharsPS(a.buff, b, Result.buff); 1279 | end; 1280 | 1281 | operator + (const a: USystemString; const b: TUPascalString): TUPascalString; 1282 | begin 1283 | CombineCharsSP(a, b.buff, Result.buff); 1284 | end; 1285 | 1286 | operator + (const a: TUPascalString; const b: USystemChar): TUPascalString; 1287 | begin 1288 | CombineCharsPC(a.buff, b, Result.buff); 1289 | end; 1290 | 1291 | operator + (const a: USystemChar; const b: TUPascalString): TUPascalString; 1292 | begin 1293 | CombineCharsCP(a, b.buff, Result.buff); 1294 | end; 1295 | 1296 | {$ENDIF} 1297 | 1298 | 1299 | function TUPascalString.GetText: USystemString; 1300 | begin 1301 | SetLength(Result, length(buff)); 1302 | if length(buff) > 0 then 1303 | CopyPtr(@buff[0], @Result[UFirstCharPos], length(buff) * USystemCharSize); 1304 | end; 1305 | 1306 | procedure TUPascalString.SetText(const Value: USystemString); 1307 | begin 1308 | SetLength(buff, length(Value)); 1309 | 1310 | if length(buff) > 0 then 1311 | CopyPtr(@Value[UFirstCharPos], @buff[0], length(buff) * USystemCharSize); 1312 | end; 1313 | 1314 | function TUPascalString.GetLen: Integer; 1315 | begin 1316 | Result := length(buff); 1317 | end; 1318 | 1319 | procedure TUPascalString.SetLen(const Value: Integer); 1320 | begin 1321 | SetLength(buff, Value); 1322 | end; 1323 | 1324 | function TUPascalString.GetChars(index: Integer): USystemChar; 1325 | begin 1326 | if (index > length(buff)) or (index <= 0) then 1327 | Result := #0 1328 | else 1329 | Result := buff[index - 1]; 1330 | end; 1331 | 1332 | procedure TUPascalString.SetChars(index: Integer; const Value: USystemChar); 1333 | begin 1334 | buff[index - 1] := Value; 1335 | end; 1336 | 1337 | procedure TUPascalString.SetBytes(const Value: TBytes); 1338 | begin 1339 | SetLength(buff, 0); 1340 | try 1341 | Text := SysUtils.TEncoding.UTF8.GetString(Value); 1342 | except 1343 | SetLength(buff, 0); 1344 | end; 1345 | end; 1346 | 1347 | function TUPascalString.GetBytes: TBytes; 1348 | begin 1349 | {$IFDEF FPC} 1350 | Result := SysUtils.TEncoding.UTF8.GetBytes(buff); 1351 | {$ELSE} 1352 | Result := SysUtils.TEncoding.UTF8.GetBytes(buff); 1353 | {$ENDIF} 1354 | end; 1355 | 1356 | function TUPascalString.GetLast: USystemChar; 1357 | begin 1358 | Result := buff[length(buff) - 1]; 1359 | end; 1360 | 1361 | procedure TUPascalString.SetLast(const Value: USystemChar); 1362 | begin 1363 | buff[length(buff) - 1] := Value; 1364 | end; 1365 | 1366 | function TUPascalString.GetFirst: USystemChar; 1367 | begin 1368 | Result := buff[0]; 1369 | end; 1370 | 1371 | procedure TUPascalString.SetFirst(const Value: USystemChar); 1372 | begin 1373 | buff[0] := Value; 1374 | end; 1375 | 1376 | {$IFDEF DELPHI} 1377 | 1378 | 1379 | class operator TUPascalString.Equal(const Lhs, Rhs: TUPascalString): Boolean; 1380 | begin 1381 | Result := (Lhs.Len = Rhs.Len) and (Lhs.Text = Rhs.Text); 1382 | end; 1383 | 1384 | class operator TUPascalString.NotEqual(const Lhs, Rhs: TUPascalString): Boolean; 1385 | begin 1386 | Result := not(Lhs = Rhs); 1387 | end; 1388 | 1389 | class operator TUPascalString.GreaterThan(const Lhs, Rhs: TUPascalString): Boolean; 1390 | begin 1391 | Result := Lhs.Text > Rhs.Text; 1392 | end; 1393 | 1394 | class operator TUPascalString.GreaterThanOrEqual(const Lhs, Rhs: TUPascalString): Boolean; 1395 | begin 1396 | Result := Lhs.Text >= Rhs.Text; 1397 | end; 1398 | 1399 | class operator TUPascalString.LessThan(const Lhs, Rhs: TUPascalString): Boolean; 1400 | begin 1401 | Result := Lhs.Text < Rhs.Text; 1402 | end; 1403 | 1404 | class operator TUPascalString.LessThanOrEqual(const Lhs, Rhs: TUPascalString): Boolean; 1405 | begin 1406 | Result := Lhs.Text <= Rhs.Text; 1407 | end; 1408 | 1409 | class operator TUPascalString.Add(const Lhs, Rhs: TUPascalString): TUPascalString; 1410 | begin 1411 | CombineCharsPP(Lhs.buff, Rhs.buff, Result.buff); 1412 | end; 1413 | 1414 | class operator TUPascalString.Add(const Lhs: USystemString; const Rhs: TUPascalString): TUPascalString; 1415 | begin 1416 | CombineCharsSP(Lhs, Rhs.buff, Result.buff); 1417 | end; 1418 | 1419 | class operator TUPascalString.Add(const Lhs: TUPascalString; const Rhs: USystemString): TUPascalString; 1420 | begin 1421 | CombineCharsPS(Lhs.buff, Rhs, Result.buff); 1422 | end; 1423 | 1424 | class operator TUPascalString.Add(const Lhs: USystemChar; const Rhs: TUPascalString): TUPascalString; 1425 | begin 1426 | CombineCharsCP(Lhs, Rhs.buff, Result.buff); 1427 | end; 1428 | 1429 | class operator TUPascalString.Add(const Lhs: TUPascalString; const Rhs: USystemChar): TUPascalString; 1430 | begin 1431 | CombineCharsPC(Lhs.buff, Rhs, Result.buff); 1432 | end; 1433 | 1434 | class operator TUPascalString.Implicit(Value: TPascalString): TUPascalString; 1435 | begin 1436 | Result.Bytes := Value.Bytes; 1437 | end; 1438 | 1439 | class operator TUPascalString.Implicit(Value: Variant): TUPascalString; 1440 | begin 1441 | Result.Text := VarToStr(Value); 1442 | end; 1443 | 1444 | class operator TUPascalString.Implicit(Value: USystemString): TUPascalString; 1445 | begin 1446 | Result.Text := Value; 1447 | end; 1448 | 1449 | class operator TUPascalString.Implicit(Value: USystemChar): TUPascalString; 1450 | begin 1451 | Result.Len := 1; 1452 | Result.buff[0] := Value; 1453 | end; 1454 | 1455 | class operator TUPascalString.Implicit(Value: TUPascalString): USystemString; 1456 | begin 1457 | Result := Value.Text; 1458 | end; 1459 | 1460 | class operator TUPascalString.Implicit(Value: TUPascalString): Variant; 1461 | begin 1462 | Result := Value.Text; 1463 | end; 1464 | 1465 | class operator TUPascalString.Explicit(Value: TUPascalString): TPascalString; 1466 | begin 1467 | Result.Bytes := Value.Bytes; 1468 | end; 1469 | 1470 | class operator TUPascalString.Explicit(Value: TUPascalString): USystemString; 1471 | begin 1472 | Result := Value.Text; 1473 | end; 1474 | 1475 | class operator TUPascalString.Explicit(Value: TUPascalString): Variant; 1476 | begin 1477 | Result := Value.Text; 1478 | end; 1479 | 1480 | class operator TUPascalString.Explicit(Value: USystemString): TUPascalString; 1481 | begin 1482 | Result.Text := Value; 1483 | end; 1484 | 1485 | class operator TUPascalString.Explicit(Value: Variant): TUPascalString; 1486 | begin 1487 | Result.Text := VarToStr(Value); 1488 | end; 1489 | 1490 | class operator TUPascalString.Explicit(Value: USystemChar): TUPascalString; 1491 | begin 1492 | Result.Len := 1; 1493 | Result.buff[0] := Value; 1494 | end; 1495 | 1496 | {$ENDIF} 1497 | 1498 | 1499 | function TUPascalString.Copy(index, Count: NativeInt): TUPascalString; 1500 | var 1501 | L: NativeInt; 1502 | begin 1503 | L := length(buff); 1504 | 1505 | if (index - 1) + Count > L then 1506 | Count := L - (index - 1); 1507 | 1508 | SetLength(Result.buff, Count); 1509 | if Count > 0 then 1510 | CopyPtr(@buff[index - 1], @Result.buff[0], USystemCharSize * Count); 1511 | end; 1512 | 1513 | function TUPascalString.Same(const p: PUPascalString): Boolean; 1514 | var 1515 | i: Integer; 1516 | s, d: USystemChar; 1517 | begin 1518 | Result := (p^.Len = Len); 1519 | if not Result then 1520 | Exit; 1521 | for i := 0 to Len - 1 do 1522 | begin 1523 | s := buff[i]; 1524 | if UCharIn(s, ucHiAtoZ) then 1525 | inc(s, 32); 1526 | d := p^.buff[i]; 1527 | if UCharIn(d, ucHiAtoZ) then 1528 | inc(d, 32); 1529 | if s <> d then 1530 | Exit(False); 1531 | end; 1532 | end; 1533 | 1534 | function TUPascalString.Same(const t: TUPascalString): Boolean; 1535 | var 1536 | i: Integer; 1537 | s, d: USystemChar; 1538 | begin 1539 | Result := (t.Len = Len); 1540 | if not Result then 1541 | Exit; 1542 | for i := 0 to Len - 1 do 1543 | begin 1544 | s := buff[i]; 1545 | if UCharIn(s, ucHiAtoZ) then 1546 | inc(s, 32); 1547 | d := t.buff[i]; 1548 | if UCharIn(d, ucHiAtoZ) then 1549 | inc(d, 32); 1550 | if s <> d then 1551 | Exit(False); 1552 | end; 1553 | end; 1554 | 1555 | function TUPascalString.Same(const t1, t2: TUPascalString): Boolean; 1556 | begin 1557 | Result := Same(@t1) or Same(@t2); 1558 | end; 1559 | 1560 | function TUPascalString.Same(const t1, t2, t3: TUPascalString): Boolean; 1561 | begin 1562 | Result := Same(@t1) or Same(@t2) or Same(@t3); 1563 | end; 1564 | 1565 | function TUPascalString.Same(const t1, t2, t3, t4: TUPascalString): Boolean; 1566 | begin 1567 | Result := Same(@t1) or Same(@t2) or Same(@t3) or Same(@t4); 1568 | end; 1569 | 1570 | function TUPascalString.Same(const t1, t2, t3, t4, t5: TUPascalString): Boolean; 1571 | begin 1572 | Result := Same(@t1) or Same(@t2) or Same(@t3) or Same(@t4) or Same(@t5); 1573 | end; 1574 | 1575 | function TUPascalString.Same(const IgnoreCase: Boolean; const t: TUPascalString): Boolean; 1576 | var 1577 | i: Integer; 1578 | s, d: USystemChar; 1579 | begin 1580 | Result := (t.Len = Len); 1581 | if not Result then 1582 | Exit; 1583 | for i := 0 to Len - 1 do 1584 | begin 1585 | s := buff[i]; 1586 | if IgnoreCase then 1587 | if UCharIn(s, ucHiAtoZ) then 1588 | inc(s, 32); 1589 | 1590 | d := t.buff[i]; 1591 | if IgnoreCase then 1592 | if UCharIn(d, ucHiAtoZ) then 1593 | inc(d, 32); 1594 | 1595 | if s <> d then 1596 | Exit(False); 1597 | end; 1598 | end; 1599 | 1600 | function TUPascalString.ComparePos(const Offset: Integer; const p: PUPascalString): Boolean; 1601 | var 1602 | i, L: Integer; 1603 | sourChar, destChar: USystemChar; 1604 | begin 1605 | Result := False; 1606 | i := 1; 1607 | L := p^.Len; 1608 | if (Offset + L - 1) > Len then 1609 | Exit; 1610 | while i <= L do 1611 | begin 1612 | sourChar := GetChars(Offset + i - 1); 1613 | destChar := p^[i]; 1614 | 1615 | if UCharIn(sourChar, ucLoAtoZ) then 1616 | dec(sourChar, 32); 1617 | if UCharIn(destChar, ucLoAtoZ) then 1618 | dec(destChar, 32); 1619 | 1620 | if sourChar <> destChar then 1621 | Exit; 1622 | inc(i); 1623 | end; 1624 | Result := True; 1625 | end; 1626 | 1627 | function TUPascalString.ComparePos(const Offset: Integer; const t: TUPascalString): Boolean; 1628 | var 1629 | i, L: Integer; 1630 | sourChar, destChar: USystemChar; 1631 | begin 1632 | Result := False; 1633 | i := 1; 1634 | L := t.Len; 1635 | if (Offset + L) > Len then 1636 | Exit; 1637 | while i <= L do 1638 | begin 1639 | sourChar := GetChars(Offset + i - 1); 1640 | destChar := t[i]; 1641 | 1642 | if UCharIn(sourChar, ucLoAtoZ) then 1643 | dec(sourChar, 32); 1644 | if UCharIn(destChar, ucLoAtoZ) then 1645 | dec(destChar, 32); 1646 | 1647 | if sourChar <> destChar then 1648 | Exit; 1649 | inc(i); 1650 | end; 1651 | Result := True; 1652 | end; 1653 | 1654 | function TUPascalString.GetPos(const s: TUPascalString; const Offset: Integer = 1): Integer; 1655 | var 1656 | i: Integer; 1657 | begin 1658 | Result := 0; 1659 | if s.Len > 0 then 1660 | for i := Offset to Len - s.Len + 1 do 1661 | if ComparePos(i, @s) then 1662 | Exit(i); 1663 | end; 1664 | 1665 | function TUPascalString.GetPos(const s: PUPascalString; const Offset: Integer = 1): Integer; 1666 | var 1667 | i: Integer; 1668 | begin 1669 | Result := 0; 1670 | if s^.Len > 0 then 1671 | for i := Offset to Len - s^.Len + 1 do 1672 | if ComparePos(i, s) then 1673 | Exit(i); 1674 | end; 1675 | 1676 | function TUPascalString.Exists(c: USystemChar): Boolean; 1677 | var 1678 | i: Integer; 1679 | begin 1680 | for i := low(buff) to high(buff) do 1681 | if buff[i] = c then 1682 | Exit(True); 1683 | Result := False; 1684 | end; 1685 | 1686 | function TUPascalString.Exists(c: array of USystemChar): Boolean; 1687 | var 1688 | i: Integer; 1689 | begin 1690 | for i := low(buff) to high(buff) do 1691 | if UCharIn(buff[i], c) then 1692 | Exit(True); 1693 | Result := False; 1694 | end; 1695 | 1696 | function TUPascalString.Exists(const s: TUPascalString): Boolean; 1697 | begin 1698 | Result := GetPos(@s, 1) > 0; 1699 | end; 1700 | 1701 | function TUPascalString.hash: TUHash; 1702 | begin 1703 | Result := UFastHashPPascalString(@Self); 1704 | end; 1705 | 1706 | function TUPascalString.Hash64: TUHash64; 1707 | begin 1708 | Result := UFastHash64PPascalString(@Self); 1709 | end; 1710 | 1711 | function TUPascalString.GetCharCount(c: USystemChar): Integer; 1712 | var 1713 | i: Integer; 1714 | begin 1715 | Result := 0; 1716 | for i := low(buff) to high(buff) do 1717 | if UCharIn(buff[i], c) then 1718 | inc(Result); 1719 | end; 1720 | 1721 | procedure TUPascalString.DeleteLast; 1722 | begin 1723 | if Len > 0 then 1724 | SetLength(buff, length(buff) - 1); 1725 | end; 1726 | 1727 | procedure TUPascalString.DeleteFirst; 1728 | begin 1729 | if Len > 0 then 1730 | buff := System.Copy(buff, 1, Len); 1731 | end; 1732 | 1733 | procedure TUPascalString.Delete(idx, cnt: Integer); 1734 | begin 1735 | if (idx + cnt <= Len) then 1736 | Text := GetString(1, idx) + GetString(idx + cnt, Len + 1) 1737 | else 1738 | Text := GetString(1, idx); 1739 | end; 1740 | 1741 | procedure TUPascalString.Clear; 1742 | begin 1743 | SetLength(buff, 0); 1744 | end; 1745 | 1746 | procedure TUPascalString.Append(t: TUPascalString); 1747 | var 1748 | r, L: Integer; 1749 | begin 1750 | L := length(t.buff); 1751 | if L > 0 then 1752 | begin 1753 | r := length(buff); 1754 | SetLength(buff, r + L); 1755 | CopyPtr(@t.buff[0], @buff[r], L * USystemCharSize); 1756 | end; 1757 | end; 1758 | 1759 | procedure TUPascalString.Append(c: USystemChar); 1760 | begin 1761 | SetLength(buff, length(buff) + 1); 1762 | buff[length(buff) - 1] := c; 1763 | end; 1764 | 1765 | function TUPascalString.GetString(bPos, ePos: NativeInt): TUPascalString; 1766 | begin 1767 | if ePos > length(buff) then 1768 | Result := Self.Copy(bPos, length(buff) - bPos + 1) 1769 | else 1770 | Result := Self.Copy(bPos, (ePos - bPos)); 1771 | end; 1772 | 1773 | procedure TUPascalString.Insert(AText: USystemString; idx: Integer); 1774 | begin 1775 | Text := GetString(1, idx) + AText + GetString(idx + 1, Len); 1776 | end; 1777 | 1778 | procedure TUPascalString.FastAsText(var output: USystemString); 1779 | begin 1780 | SetLength(output, length(buff)); 1781 | if length(buff) > 0 then 1782 | CopyPtr(@buff[0], @output[UFirstCharPos], length(buff) * USystemCharSize); 1783 | end; 1784 | 1785 | procedure TUPascalString.FastGetBytes(var output: TBytes); 1786 | begin 1787 | {$IFDEF FPC} 1788 | output := SysUtils.TEncoding.UTF8.GetBytes(buff); 1789 | {$ELSE} 1790 | output := SysUtils.TEncoding.UTF8.GetBytes(buff); 1791 | {$ENDIF} 1792 | end; 1793 | 1794 | function TUPascalString.LowerText: USystemString; 1795 | begin 1796 | Result := LowerCase(Text); 1797 | end; 1798 | 1799 | function TUPascalString.UpperText: USystemString; 1800 | begin 1801 | Result := UpperCase(Text); 1802 | end; 1803 | 1804 | function TUPascalString.Invert: TUPascalString; 1805 | var 1806 | i, j: Integer; 1807 | begin 1808 | SetLength(Result.buff, length(buff)); 1809 | j := low(Result.buff); 1810 | for i := high(buff) downto low(buff) do 1811 | begin 1812 | Result.buff[j] := buff[i]; 1813 | inc(j); 1814 | end; 1815 | end; 1816 | 1817 | function TUPascalString.TrimChar(const Chars: TUPascalString): TUPascalString; 1818 | var 1819 | L, bp, EP: Integer; 1820 | begin 1821 | Result := ''; 1822 | L := Len; 1823 | if L > 0 then 1824 | begin 1825 | bp := 1; 1826 | while UCharIn(GetChars(bp), @Chars) do 1827 | begin 1828 | inc(bp); 1829 | if (bp > L) then 1830 | begin 1831 | Result := ''; 1832 | Exit; 1833 | end; 1834 | end; 1835 | if bp > L then 1836 | Result := '' 1837 | else 1838 | begin 1839 | EP := L; 1840 | 1841 | while UCharIn(GetChars(EP), @Chars) do 1842 | begin 1843 | dec(EP); 1844 | if (EP < 1) then 1845 | begin 1846 | Result := ''; 1847 | Exit; 1848 | end; 1849 | end; 1850 | Result := GetString(bp, EP + 1); 1851 | end; 1852 | end; 1853 | end; 1854 | 1855 | function TUPascalString.DeleteChar(const Chars: TUPascalString): TUPascalString; 1856 | var 1857 | c: USystemChar; 1858 | begin 1859 | Result := ''; 1860 | for c in buff do 1861 | if not UCharIn(c, @Chars) then 1862 | Result.Append(c); 1863 | end; 1864 | 1865 | function TUPascalString.DeleteChar(const Chars: TUOrdChars): TUPascalString; 1866 | var 1867 | c: USystemChar; 1868 | begin 1869 | Result := ''; 1870 | for c in buff do 1871 | if not UCharIn(c, Chars) then 1872 | Result.Append(c); 1873 | end; 1874 | 1875 | function TUPascalString.ReplaceChar(const Chars: TUPascalString; const newChar: USystemChar): TUPascalString; 1876 | var 1877 | i: Integer; 1878 | begin 1879 | Result.Len := Len; 1880 | for i := low(buff) to high(buff) do 1881 | if UCharIn(buff[i], Chars) then 1882 | Result.buff[i] := newChar 1883 | else 1884 | Result.buff[i] := buff[i]; 1885 | end; 1886 | 1887 | function TUPascalString.ReplaceChar(const Chars, newChar: USystemChar): TUPascalString; 1888 | var 1889 | i: Integer; 1890 | begin 1891 | Result.Len := Len; 1892 | for i := low(buff) to high(buff) do 1893 | if UCharIn(buff[i], Chars) then 1894 | Result.buff[i] := newChar 1895 | else 1896 | Result.buff[i] := buff[i]; 1897 | end; 1898 | 1899 | function TUPascalString.ReplaceChar(const Chars: TUOrdChars; const newChar: USystemChar): TUPascalString; 1900 | var 1901 | i: Integer; 1902 | begin 1903 | Result.Len := Len; 1904 | for i := low(buff) to high(buff) do 1905 | if UCharIn(buff[i], Chars) then 1906 | Result.buff[i] := newChar 1907 | else 1908 | Result.buff[i] := buff[i]; 1909 | end; 1910 | 1911 | function TUPascalString.SmithWaterman(const p: PUPascalString): Double; 1912 | begin 1913 | Result := USmithWatermanCompare(@Self, @p); 1914 | end; 1915 | 1916 | function TUPascalString.SmithWaterman(const s: TUPascalString): Double; 1917 | begin 1918 | Result := USmithWatermanCompare(@Self, @s); 1919 | end; 1920 | 1921 | function TUPascalString.BOMBytes: TBytes; 1922 | begin 1923 | {$IFDEF FPC} 1924 | Result := GetBytes; 1925 | {$ELSE} 1926 | Result := SysUtils.TEncoding.UTF8.GetPreamble + GetBytes; 1927 | {$ENDIF} 1928 | end; 1929 | 1930 | initialization 1931 | 1932 | finalization 1933 | 1934 | end. 1935 | 1936 | -------------------------------------------------------------------------------- /zDefine.inc: -------------------------------------------------------------------------------- 1 | { * https://zpascal.net * } 2 | { * https://github.com/PassByYou888/zAI * } 3 | { * https://github.com/PassByYou888/ZServer4D * } 4 | { * https://github.com/PassByYou888/PascalString * } 5 | { * https://github.com/PassByYou888/zRasterization * } 6 | { * https://github.com/PassByYou888/CoreCipher * } 7 | { * https://github.com/PassByYou888/zSound * } 8 | { * https://github.com/PassByYou888/zChinese * } 9 | { * https://github.com/PassByYou888/zExpression * } 10 | { * https://github.com/PassByYou888/zGameWare * } 11 | { * https://github.com/PassByYou888/zAnalysis * } 12 | { * https://github.com/PassByYou888/FFMPEG-Header * } 13 | { * https://github.com/PassByYou888/zTranslate * } 14 | { * https://github.com/PassByYou888/InfiniteIoT * } 15 | { * https://github.com/PassByYou888/FastMD5 * } 16 | { ****************************************************************************** } 17 | 18 | {$IFDEF FPC} 19 | {$IFDEF FPC_DELPHI_MODE} 20 | {$MODE delphi} 21 | {$ELSE FPC_DELPHI_MODE} 22 | {$MODE objfpc} 23 | {$ENDIF FPC_DELPHI_MODE} 24 | 25 | {$MODESWITCH AdvancedRecords} 26 | {$MODESWITCH NestedProcVars} 27 | {$NOTES OFF} 28 | {$STACKFRAMES OFF} 29 | {$COPERATORS OFF} 30 | {$GOTO ON} 31 | {$INLINE ON} 32 | {$MACRO OFF} 33 | 34 | {$DEFINE LITTLE_ENDIAN} 35 | {$UNDEF BIG_ENDIAN} 36 | {$IFDEF FPC_BIG_ENDIAN} 37 | {$UNDEF LITTLE_ENDIAN} 38 | {$DEFINE BIG_ENDIAN} 39 | {$ENDIF} 40 | 41 | {$UNDEF FirstCharInZero} 42 | 43 | {$UNDEF Delphi} 44 | 45 | // nativeint as int or int64 type variable when Modifier is overload 46 | {$UNDEF OVERLOAD_NATIVEINT} 47 | 48 | // fast MD5 only delphi supported, https://github.com/PassByYou888/FastMD5 49 | {$UNDEF FastMD5} 50 | 51 | // stream is MemoryStream64 or MemoryStream, usage fastMD5 or PurePascal MD5 52 | // be associate api: UnicodeMixedLib.umlStreamMD5, Fast_MD5.FastMD5 53 | {$DEFINE OptimizationMemoryStreamMD5} 54 | 55 | // multi thread Parallel switch. 56 | {$DEFINE Parallel} 57 | 58 | // Parallel for fold make better use CPU of multi core 59 | // if rem this "FoldParallel" parallel for block program, thread can use linear address 60 | {$DEFINE FoldParallel} 61 | 62 | // MT19937 of seed in the startup TComputeThread is 0 63 | {$DEFINE MT19937SeedOnTComputeThreadIs0} 64 | 65 | // automated loading common AI data sets on boot-time 66 | {$DEFINE Z_AI_Dataset_Build_In} 67 | 68 | // With SMALL_RASTER_FONT_Build_In and LARGE_RASTER_FONT_Build_In, boot-time memory usage increase by 100M-200M and start-up time to be delay 100ms 69 | {$DEFINE SMALL_RASTER_FONT_Build_In} 70 | // {$DEFINE LARGE_RASTER_FONT_Build_In} 71 | 72 | // ZDB_BACKUP is automatically made and replica caching is enabled. 73 | // usage ZDB_BACKUP so slows the open of large size ZDB file, after time, but does is high performance. 74 | // {$DEFINE ZDB_BACKUP} 75 | 76 | // ZDB Flush() uses physical IO as the temp storage device 77 | // {$DEFINE ZDB_PHYSICAL_FLUSH} 78 | 79 | // used Critical Simulate Atomic with TMonitor.Enter(obj) and TMonitor.Exit(obj) 80 | // CriticalSimulateAtomic defined so performance to be reduced 81 | {$DEFINE CriticalSimulateAtomic} 82 | 83 | // used soft Simulate Critical(ring) 84 | // SoftCritical defined so performance to be reduced 85 | // {$DEFINE SoftCritical} 86 | // {$DEFINE ANTI_DEAD_ATOMIC_LOCK} 87 | 88 | {$UNDEF debug} 89 | {$DEFINE release} 90 | {$DEFINE INLINE_ASM} 91 | {$R-} { range check } 92 | {$ELSE FPC} { IF DELPHI } 93 | {$DEFINE LITTLE_ENDIAN} 94 | {$UNDEF BIG_ENDIAN} 95 | 96 | {$IFDEF VER340} 97 | {$UNDEF FirstCharInZero} 98 | {$ELSE VER340} 99 | {$IFDEF ANDROID} 100 | {$DEFINE FirstCharInZero} 101 | {$ENDIF ANDROID} 102 | 103 | {$IFDEF IOS} 104 | {$DEFINE FirstCharInZero} 105 | {$ENDIF IOS} 106 | {$ENDIF VER340} 107 | 108 | {$DEFINE Delphi} 109 | 110 | // nativeint as int or int64 type variable when Modifier is overload 111 | {$DEFINE OVERLOAD_NATIVEINT} 112 | 113 | // fast MD5 only delphi supported, https://github.com/PassByYou888/FastMD5 114 | {$DEFINE FastMD5} 115 | 116 | // stream is MemoryStream64 or MemoryStream, usage fastMD5 or PurePascal MD5 117 | // be associate api: UnicodeMixedLib.umlStreamMD5, Fast_MD5.FastMD5 118 | {$DEFINE OptimizationMemoryStreamMD5} 119 | 120 | // multi thread Parallel switch. 121 | {$DEFINE Parallel} 122 | 123 | // Parallel for fold make better use CPU of multi core 124 | // if rem this "FoldParallel" is parallel for block program, thread can use linear address 125 | {$DEFINE FoldParallel} 126 | 127 | // Parallel programs use the delphi default TParallel 128 | // {$DEFINE SystemParallel} 129 | 130 | // paper: Mersenne Twister: A 623-dimensionallyequidistributed uniformpseudorandom number generator 131 | // Using this paper replace of Delphi Random() and Randomize() function, work on xe 10.3 or laster 132 | // {$DEFINE InstallMT19937CoreToDelphi} 133 | 134 | // MT19937 of seed in the startup TComputeThread is 0 135 | {$DEFINE MT19937SeedOnTComputeThreadIs0} 136 | 137 | // automated loading common AI data sets on boot-time 138 | // {$DEFINE Z_AI_Dataset_Build_In} 139 | 140 | // With SMALL_RASTER_FONT_Build_In and LARGE_RASTER_FONT_Build_In, boot-time memory usage increase by 100M-200M and start-up time to be delay 100ms 141 | // {$DEFINE SMALL_RASTER_FONT_Build_In} 142 | // {$DEFINE LARGE_RASTER_FONT_Build_In} 143 | 144 | // ZDB_BACKUP is automatically made and replica caching is enabled. 145 | // usage ZDB_BACKUP so slows the open of large size ZDB file, after time, but does is high performance. 146 | // {$DEFINE ZDB_BACKUP} 147 | 148 | // ZDB Flush() uses physical IO as the temp storage device 149 | // {$DEFINE ZDB_PHYSICAL_FLUSH} 150 | 151 | // used Critical Simulate Atomic with TMonitor.Enter(obj) and TMonitor.Exit(obj) 152 | // CriticalSimulateAtomic defined so performance to be reduced 153 | // {$DEFINE CriticalSimulateAtomic} 154 | 155 | // used soft Simulate Critical(ring) 156 | // SoftCritical defined so performance to be reduced 157 | // {$DEFINE SoftCritical} 158 | // {$DEFINE ANTI_DEAD_ATOMIC_LOCK} 159 | 160 | {$IFDEF release} 161 | {$DEFINE INLINE_ASM} 162 | {$R-} { range check } 163 | {$I-} { Input output checking } 164 | {$IF Defined(Android) or Defined(IOS)} 165 | {$O-} { close optimization } 166 | {$ELSE} 167 | {$O+} { open optimization } 168 | {$INLINE AUTO} { inline } 169 | {$IFEND} 170 | {$ELSE} 171 | {$UNDEF INLINE_ASM} 172 | {$O-} { close optimization } 173 | {$R-} { range check } 174 | {$I-} { Input output checking } 175 | {$D+} { debug information } 176 | {$ENDIF} 177 | 178 | {$IF Defined(Android) or Defined(IOS)} 179 | {$DEFINE SMALL_RASTER_FONT_Build_In} 180 | {$DEFINE PhysicsIO_On_Indy} 181 | {$ELSE} 182 | // PhysicsIO interface 183 | // {$DEFINE PhysicsIO_On_ICS} 184 | {$DEFINE PhysicsIO_On_CrossSocket} 185 | // {$DEFINE PhysicsIO_On_DIOCP} 186 | // {$DEFINE PhysicsIO_On_Indy} 187 | // {$DEFINE PhysicsIO_On_Synapse} 188 | {$IFEND} 189 | 190 | {$X+} { Extended syntax } 191 | {$Z1} { Minimum enum size } 192 | {$ENDIF FPC} 193 | 194 | 195 | 196 | {$IFDEF DEBUG} 197 | // initialization status prompt 198 | {$DEFINE initializationStatus} 199 | // warning prompt 200 | {$WARNINGS ON} 201 | {$ELSE DEBUG} 202 | // initialization status prompt 203 | {$UNDEF initializationStatus} 204 | // warning prompt 205 | {$WARNINGS OFF} 206 | {$ENDIF DEBUG} 207 | 208 | {$HINTS OFF} 209 | {$C+} { Assertions } 210 | {$M-} { Run-Time Type Information } 211 | {$H+} { long string } 212 | {$A+} { Word Align Data } 213 | {$Q-} { Overflow checking } 214 | {$B-} { Complete boolean evaluation } 215 | {$J+} { Writeable typed constants } 216 | 217 | (* 218 | Pointer math is simply treating any given typed pointer in some narrow, 219 | instances as a scaled ordinal where you can perform simple arithmetic operations directly on the pointer variable. 220 | *) 221 | {$POINTERMATH OFF} 222 | 223 | {$UNDEF CPU64} 224 | 225 | {$IFDEF CPU64BITS} 226 | {$DEFINE CPU64} 227 | {$ELSE CPU64BITS} 228 | {$IFDEF CPUX64} 229 | {$DEFINE CPU64} 230 | {$ENDIF CPUX64} 231 | {$ENDIF CPU64BITS} 232 | 233 | {$IFNDEF CPU64} 234 | {$DEFINE CPU32} 235 | {$ENDIF CPU64} 236 | 237 | {$IFDEF BIG_ENDIAN} 238 | {$MESSAGE FATAL 'Big-endian system not supported'} 239 | {$ENDIF BIG_ENDIAN} 240 | 241 | {$IFOPT R+} 242 | {$DEFINE RangeCheck} 243 | {$ENDIF} 244 | 245 | {$IFOPT Q+} 246 | {$DEFINE OverflowCheck} 247 | {$ENDIF} 248 | --------------------------------------------------------------------------------