Why Gemfury?
Push, build, and install
RubyGems
npm packages
Python packages
Maven artifacts
PHP packages
Go Modules
Debian packages
RPM packages
NuGet packages
beefree / lazarus-project deb
Repository URL to install this package:
|
Version:
2.0.10 ▾
|
//----------------------------------------------------------------------------
// Anti-Grain Geometry - Version 2.4 (Public License)
// Copyright (C) 2002-2005 Maxim Shemanarev (http://www.antigrain.com)
//
// Anti-Grain Geometry - Version 2.4 Release Milano 3 (AggPas 2.4 RM3)
// Pascal Port By: Milan Marusinec alias Milano
// milan@marusinec.sk
// http://www.aggpas.org
// Copyright (c) 2005-2006
//
// Permission to copy, use, modify, sell and distribute this software
// is granted provided this copyright notice appears in all copies.
// This software is provided "as is" without express or implied
// warranty, and with no claim as to its suitability for any purpose.
//
//----------------------------------------------------------------------------
// Contact: mcseem@antigrain.com
// mcseemagg@yahoo.com
// http://www.antigrain.com
//
// [Pascal Port History] -----------------------------------------------------
//
// 23.06.2006-Milano: added ptrcomp type + ptrcomp adjustments
// 26.09.2005-Milano: Complete unit port
//
{ agg_basics.pas }
unit
agg_basics ;
INTERFACE
{$I agg_mode.inc }
{$Q- }
{$R- }
uses
Math ;
{ TYPES DEFINITION }
type
agg_types = (
int8_type ,
int8u_type ,
int16_type ,
int16u_type ,
int32_type ,
int32u_type ,
int64_type ,
int64u_type
);
agg_type = (agg_int ,agg_unsigned ,agg_double );
AGG_INT8 = shortint;
AGG_INT8U = byte;
AGG_INT16 = smallint;
AGG_INT16U = word;
AGG_INT32 = longint;
AGG_INT32U = longword;
AGG_INT64 = int64;
{$IFDEF FPC }
AGG_INT64U = qword;
{$ELSE }
AGG_INT64U = int64;
{$ENDIF }
int8 = AGG_INT8;
int8u = AGG_INT8U;
int16 = AGG_INT16;
int16u = AGG_INT16U;
int32 = AGG_INT32;
int32u = AGG_INT32U;
int64 = AGG_INT64;
int64u = AGG_INT64U;
int8_ptr = ^int8;
int8u_ptr = ^int8u;
int16_ptr = ^int16;
int16u_ptr = ^int16u;
int32_ptr = ^int32;
int32u_ptr = ^int32u;
int64_ptr = ^int64;
int64u_ptr = ^int64u;
int8u_ptr_ptr = ^int8u_ptr;
cover_type_ptr = ^cover_type;
cover_type = byte;
int_ptr = ^int;
int = int32;
unsigned_ptr = ^unsigned;
unsigned = int32u;
int8u_01_ptr = ^int8u_01;
int8u_01 = array[0..1 ] of int8u;
int16u_ = record
low ,
high : int8u;
end;
int32_ = record
low ,
high : int16;
end;
int32_int8u = record
_0 ,_1 ,_2 ,_3 : int8u;
end;
int32u_ = record
low ,
high : int16u;
end;
{ To achive maximum compatiblity with older code, FPC doesn't change the size
of predefined data types like integer, longint or word when changing from
32 to 64 Bit. However, the size of a pointer is 8 bytes on a 64 bit
architecture so constructs like longint(pointer(p)) are doomed to crash on
64 bit architectures. However, to allow you to write portable code, the
FPC system unit introduces the types PtrInt and PtrUInt which are signed
and unsigned integer data types with the same size as a pointer.
Keep in mind that the size change of the "pointer" type also affects record
sizes. If you allocate records with fixed sizes, and not with new or with
getmem (<x>,sizeof(<x>)), this will have to be fixed. }
// Pascal Pointer Computation Type
{$IFDEF CPU64 }
ptrcomp = system.int64;
{$ELSE }
ptrcomp = integer;
{$ENDIF }
// Pascal's pointer-in-an-array-access helper structures
p32_ptr = ^p32;
p32 = record
case integer of
1 : (ptr : pointer );
2 : (int : ptrcomp );
end;
double_ptr_ptr = ^double_ptr;
double_ptr = ^double;
double_2_ptr = ^double_2;
double_2 = array[0..1 ] of double;
double_8_ptr = ^double_8;
double_8 = array[0..7 ] of double;
double_42_ptr = ^double_42;
double_42 = array[0..3 ,0..1 ] of double;
double_44_ptr = ^double_44;
double_44 = array[0..3 ,0..3 ] of double;
double_81_ptr = ^double_81;
double_81 = array[0..7 ,0..0 ] of double;
double_88_ptr = ^double_88;
double_88 = array[0..7 ,0..7 ] of double;
double_26_ptr = ^double_26;
double_26 = array[0..25 ] of double;
double_00_ptr = ^double_00;
double_00 = array of double;
char_ptr_ptr = ^char_ptr;
char_ptr = ^char;
pointer_ptr = ^pointer;
gamma_ptr = ^gamma;
gamma = object
function dir(v : unsigned ) : unsigned; virtual; abstract;
function inv(v : unsigned ) : unsigned; virtual; abstract;
end;
poly_subpixel_scale_e = int;
filling_rule_e = (fill_non_zero ,fill_even_odd );
const
// cover_scale_e
cover_shift = 8;
cover_size = 1 shl cover_shift;
cover_mask = cover_size - 1;
cover_none = 0;
cover_full = cover_mask;
pi : double = 3.14159265358979323846;
// These constants determine the subpixel accuracy, to be more precise,
// the number of bits of the fractional part of the coordinates.
// The possible coordinate capacity in bits can be calculated by formula:
// sizeof(int) * 8 - poly_subpixel_shift, i.e, for 32-bit integers and
// 8-bits fractional part the capacity is 24 bits.
poly_subpixel_shift = 8; //----poly_subpixel_shift
poly_subpixel_scale = 1 shl poly_subpixel_shift; //----poly_subpixel_scale
poly_subpixel_mask = poly_subpixel_scale-1; //----poly_subpixel_mask
// path_commands_e
path_cmd_stop = 0;
path_cmd_move_to = 1;
path_cmd_line_to = 2;
path_cmd_curve3 = 3;
path_cmd_curve4 = 4;
path_cmd_curveN = 5;
path_cmd_catrom = 6;
path_cmd_ubspline = 7;
path_cmd_end_poly = $0F;
path_cmd_mask = $0F;
// path_flags_e
path_flags_none = 0;
path_flags_ccw = $10;
path_flags_cw = $20;
path_flags_close = $40;
path_flags_mask = $F0;
type
rect_ptr = ^rect;
rect = object
x1 ,y1 ,x2 ,y2 : int;
constructor Construct; overload;
constructor Construct(x1_ ,y1_ ,x2_ ,y2_ : int ); overload;
constructor Construct(r : rect_ptr ); overload;
function normalize : rect_ptr;
function clip(r : rect_ptr ) : boolean;
function is_valid : boolean;
end;
rect_d_ptr = ^rect_d;
rect_d = object
x1 ,y1 ,x2 ,y2 : double;
constructor Construct; overload;
constructor Construct(x1_ ,y1_ ,x2_ ,y2_ : double ); overload;
function normalize : rect_d_ptr;
function clip(r : rect_d_ptr ) : boolean;
function is_valid : boolean;
end;
rect_i_ptr = ^rect_i;
rect_i = object
x1 ,y1 ,x2 ,y2 : int;
constructor Construct; overload;
constructor Construct(x1_ ,y1_ ,x2_ ,y2_ : int ); overload;
function clip(r : rect_i_ptr ) : boolean;
end;
point_type_ptr = ^point_type;
point_type = record
x ,y : double;
end;
vertex_type = object
x ,y : double;
cmd : byte;
constructor Construct; overload;
constructor Construct(x_ ,y_ : double; cmd_ : byte ); overload;
end;
unsigned_list_ptr = ^unsigned_list;
unsigned_list = object
function array_operator(idx : unsigned ) : unsigned; virtual; abstract;
end;
{ GLOBAL PROCEDURES }
function agg_getmem (var buf : pointer; sz : unsigned ) : boolean;
function agg_freemem(var buf : pointer; sz : unsigned ) : boolean;
function deg2rad(deg : double ) : double;
function rad2deg(rad : double ) : double;
procedure normalize_rect (var this : rect );
procedure normalize_rect_d(var this : rect_d );
function clip_rect (var this : rect; r : rect_ptr ) : boolean;
function clip_rect_d(var this : rect_d; r : rect_d_ptr ) : boolean;
function is_valid_rect (var this : rect ) : boolean;
function is_valid_rect_d(var this : rect_d ) : boolean;
function intersect_rectangles (r1 ,r2 : rect_ptr ) : rect;
function intersect_rectangles_d(r1 ,r2 : rect_d_ptr ) : rect_d;
function unite_rectangles (r1 ,r2 : rect_ptr ) : rect;
function unite_rectangles_d(r1 ,r2 : rect_d_ptr ) : rect_d;
function is_vertex (c : unsigned ) : boolean;
function is_drawing (c : unsigned ) : boolean;
function is_stop (c : unsigned ) : boolean;
function is_move (c : unsigned ) : boolean;
function is_line_to (c : unsigned ) : boolean;
function is_move_to (c : unsigned ) : boolean;
function is_curve (c : unsigned ) : boolean;
function is_curve3 (c : unsigned ) : boolean;
function is_curve4 (c : unsigned ) : boolean;
function is_end_poly (c : unsigned ) : boolean;
function is_close (c : unsigned ) : boolean;
function is_next_poly(c : unsigned ) : boolean;
function is_cw (c : unsigned ) : boolean;
function is_ccw (c : unsigned ) : boolean;
function is_oriented (c : unsigned ) : boolean;
function is_closed (c : unsigned ) : boolean;
function get_close_flag (c : unsigned ) : unsigned;
function clear_orientation(c : unsigned ) : unsigned;
function get_orientation (c : unsigned ) : unsigned;
function set_orientation (c ,o : unsigned ) : unsigned;
procedure swap_ptrs(a ,b : pointer );
procedure sprintf (dst : char_ptr; src : PChar; val : double );
function intdbl (i : int ) : double;
procedure srand_(seed : int );
function rand_ : int;
procedure srand(seed : int );
function rand : int;
function uround(v : double ) : int;
function iround(v : double ) : int;
function saturation_iround(Limit : int; v : double ) : int;
// NoP = No Operation. It's the empty function, whose purpose is only for the
// debugging, or for the piece of code where intentionaly nothing is planned
// to be.
procedure NoP;
{ These implementations have changed to use FPC's Sar*() functions, so should
now support all platforms without the need for ASM code. At a later date these
functions could be removed completely. }
function shr_int8 (i ,shift : int8 ) : int8; inline;
function shr_int16(i ,shift : int16 ) : int16; inline;
function shr_int32(i ,shift : int ) : int; inline;
IMPLEMENTATION
{ UNIT IMPLEMENTATION }
{ agg_getmem }
function agg_getmem;
begin
result:=false;
try
getmem(buf ,sz );
result:=true;
except
buf:=NIL;
end;
end;
{ agg_freemem }
function agg_freemem;
begin
if buf = NIL then
result:=true
else
try
freemem(buf ,sz );
buf:=NIL;
result:=true;
except
result:=false;
end;
end;
{ deg2rad }
function deg2rad;
begin
result:=deg * pi / 180;
end;
{ rad2deg }
function rad2deg;
begin
result:=rad * 180 / pi;
end;
{ CONSTRUCT }
constructor rect.Construct;
begin
x1:=0;
y1:=0;
x2:=0;
y2:=0;
end;
{ CONSTRUCT }
constructor rect.Construct(x1_ ,y1_ ,x2_ ,y2_ : int );
begin
x1:=x1_;
y1:=y1_;
x2:=x2_;
y2:=y2_;
end;
{ CONSTRUCT }
constructor rect.Construct(r : rect_ptr );
begin
x1:=r.x1;
y1:=r.y1;
x2:=r.x2;
y2:=r.y2;
end;
{ NORMALIZE }
function rect.normalize: rect_ptr;
var
t : int;
begin
if x1 > x2 then
begin
t :=x1;
x1:=x2;
x2:=t;
end;
if y1 > y2 then
begin
t :=y1;
y1:=y2;
y2:=t;
end;
result:=@self;
end;
{ CLIP }
function rect.clip(r: rect_ptr): boolean;
begin
if x2 > r.x2 then
x2:=r.x2;
if y2 > r.y2 then
y2:=r.y2;
if x1 < r.x1 then
x1:=r.x1;
if y1 < r.y1 then
y1:=r.y1;
result:=(x1 <= x2 ) and (y1 <= y2 );
end;
{ IS_VALID }
function rect.is_valid: boolean;
begin
result:=(x1 <= x2 ) and (y1 <= y2 );
end;
{ CONSTRUCT }
constructor rect_d.Construct;
begin
x1:=0;
y1:=0;
x2:=0;
y2:=0;
end;
{ CONSTRUCT }
constructor rect_d.Construct(x1_ ,y1_ ,x2_ ,y2_ : double );
begin
x1:=x1_;
y1:=y1_;
x2:=x2_;
y2:=y2_;
end;
{ NORMALIZE }
function rect_d.normalize;
var
t : double;
begin
if x1 > x2 then
begin
t :=x1;
x1:=x2;
x2:=t;
end;
if y1 > y2 then
begin
t :=y1;
y1:=y2;
y2:=t;
end;
result:=@self;
end;
{ CLIP }
function rect_d.clip;
begin
if x2 > r.x2 then
x2:=r.x2;
if y2 > r.y2 then
y2:=r.y2;
if x1 < r.x1 then
x1:=r.x1;
if y1 < r.y1 then
y1:=r.y1;
result:=(x1 <= x2 ) and (y1 <= y2 );
end;
{ IS_VALID }
function rect_d.is_valid;
begin
result:=(x1 <= x2 ) and (y1 <= y2 );
end;
{ CONSTRUCT }
constructor rect_i.Construct;
begin
x1:=0;
y1:=0;
x2:=0;
y2:=0;
end;
{ CONSTRUCT }
constructor rect_i.Construct(x1_ ,y1_ ,x2_ ,y2_ : int );
begin
x1:=x1_;
y1:=y1_;
x2:=x2_;
y2:=y2_;
end;
{ CLIP }
function rect_i.clip(r : rect_i_ptr ) : boolean;
begin
if x2 > r.x2 then
x2:=r.x2;
if y2 > r.y2 then
y2:=r.y2;
if x1 < r.x1 then
x1:=r.x1;
if y1 < r.y1 then
y1:=r.y1;
result:=(x1 <= x2 ) and (y1 <= y2 );
end;
{ CONSTRUCT }
constructor vertex_type.Construct;
begin
x:=0;
y:=0;
cmd:=0;
end;
{ CONSTRUCT }
constructor vertex_type.Construct(x_ ,y_ : double; cmd_ : byte );
begin
x:=x_;
y:=y_;
cmd:=cmd_;
end;
{ normalize_rect }
procedure normalize_rect(var this : rect );
var
t : int;
begin
if this.x1 > this.x2 then
begin
t :=this.x1;
this.x1:=this.x2;
this.x2:=t;
end;
if this.y1 > this.y2 then
begin
t :=this.y1;
this.y1:=this.y2;
this.y2:=t;
end;
end;
{ normalize_rect_d }
procedure normalize_rect_d(var this : rect_d );
var
t : double;
begin
if this.x1 > this.x2 then
begin
t :=this.x1;
this.x1:=this.x2;
this.x2:=t;
end;
if this.y1 > this.y2 then
begin
t :=this.y1;
this.y1:=this.y2;
this.y2:=t;
end;
end;
{ clip_rect }
function clip_rect(var this : rect; r : rect_ptr ) : boolean;
begin
if this.x2 > r.x2 then
this.x2:=r.x2;
if this.y2 > r.y2 then
this.y2:=r.y2;
if this.x1 < r.x1 then
this.x1:=r.x1;
if this.y1 < r.y1 then
this.y1:=r.y1;
result:=(this.x1 <= this.x2 ) and (this.y1 <= this.y2 );
end;
{ clip_rect_d }
function clip_rect_d(var this : rect_d; r : rect_d_ptr ) : boolean;
begin
if this.x2 > r.x2 then
this.x2:=r.x2;
if this.y2 > r.y2 then
this.y2:=r.y2;
if this.x1 < r.x1 then
this.x1:=r.x1;
if this.y1 < r.y1 then
this.y1:=r.y1;
result:=(this.x1 <= this.x2 ) and (this.y1 <= this.y2 );
end;
{ is_valid_rect }
function is_valid_rect(var this : rect ) : boolean;
begin
result:=(this.x1 <= this.x2 ) and (this.y1 <= this.y2 );
end;
{ is_valid_rect_d }
function is_valid_rect_d(var this : rect_d ) : boolean;
begin
result:=(this.x1 <= this.x2 ) and (this.y1 <= this.y2 );
end;
{ intersect_rectangles }
function intersect_rectangles(r1 ,r2 : rect_ptr ) : rect;
begin
result:=r1^;
if result.x2 > r2.x2 then
result.x2:=r2.x2;
if result.y2 > r2.y2 then
result.y2:=r2.y2;
if result.x1 < r2.x1 then
result.x1:=r2.x1;
if result.y1 < r2.y1 then
result.y1:=r2.y1;
end;
{ intersect_rectangles_d }
function intersect_rectangles_d(r1 ,r2 : rect_d_ptr ) : rect_d;
begin
result:=r1^;
if result.x2 > r2.x2 then
result.x2:=r2.x2;
if result.y2 > r2.y2 then
result.y2:=r2.y2;
if result.x1 < r2.x1 then
result.x1:=r2.x1;
if result.y1 < r2.y1 then
result.y1:=r2.y1;
end;
{ unite_rectangles }
function unite_rectangles(r1 ,r2 : rect_ptr ) : rect;
begin
result:=r1^;
if result.x2 < r2.x2 then
result.x2:=r2.x2;
if result.y2 < r2.y2 then
result.y2:=r2.y2;
if result.x1 > r2.x1 then
result.x1:=r2.x1;
if result.y1 > r2.y1 then
result.y1:=r2.y1;
end;
{ unite_rectangles_d }
function unite_rectangles_d(r1 ,r2 : rect_d_ptr ) : rect_d;
begin
result:=r1^;
if result.x2 < r2.x2 then
result.x2:=r2.x2;
if result.y2 < r2.y2 then
result.y2:=r2.y2;
if result.x1 > r2.x1 then
result.x1:=r2.x1;
if result.y1 > r2.y1 then
result.y1:=r2.y1;
end;
{ is_vertex }
function is_vertex;
begin
result:=(c >= path_cmd_move_to ) and (c < path_cmd_end_poly );
end;
{ is_drawing }
function is_drawing;
begin
result:=(c >= path_cmd_line_to ) and (c < path_cmd_end_poly );
end;
{ is_stop }
function is_stop;
begin
result:=(c = path_cmd_stop );
end;
{ is_move }
function is_move;
begin
result:=(c = path_cmd_move_to );
end;
{ is_line_to }
function is_line_to;
begin
result:=(c = path_cmd_line_to );
end;
{ is_move_to }
function is_move_to;
begin
result:=(c = path_cmd_move_to );
end;
{ is_curve }
function is_curve;
begin
result:=(c = path_cmd_curve3 ) or (c = path_cmd_curve4 );
end;
{ is_curve3 }
function is_curve3;
begin
result:=(c = path_cmd_curve3 );
end;
{ is_curve4 }
function is_curve4;
begin
result:=(c = path_cmd_curve4 );
end;
{ is_end_poly }
function is_end_poly;
begin
result:=((c and path_cmd_mask ) = path_cmd_end_poly );
end;
{ is_close }
function is_close;
begin
result:=
(c and not(path_flags_cw or path_flags_ccw ) ) =
(path_cmd_end_poly or path_flags_close )
end;
{ is_next_poly }
function is_next_poly;
begin
result:=is_stop(c ) or is_move_to(c ) or is_end_poly(c );
end;
{ is_cw }
function is_cw;
begin
result:=not((c and path_flags_cw ) = 0 );
end;
{ is_ccw }
function is_ccw;
begin
result:=not((c and path_flags_ccw ) = 0 );
end;
{ is_oriented }
function is_oriented;
begin
result:=not((c and (path_flags_cw or path_flags_ccw ) ) = 0 );
end;
{ is_closed }
function is_closed;
begin
result:=not((c and path_flags_close ) = 0 );
end;
{ get_close_flag }
function get_close_flag;
begin
result:=c and path_flags_close;
end;
{ clear_orientation }
function clear_orientation;
begin
result:=c and not(path_flags_cw or path_flags_ccw );
end;
{ get_orientation }
function get_orientation;
begin
result:=c and (path_flags_cw or path_flags_ccw );
end;
{ set_orientation }
function set_orientation;
begin
result:=clear_orientation(c ) or o;
end;
{ swap_ptrs }
procedure swap_ptrs;
var
temp : pointer;
begin
temp:=p32_ptr(a ).ptr;
p32_ptr(a ).ptr:=p32_ptr(b ).ptr;
p32_ptr(b ).ptr:=temp;
end;
{ MAKESTR }
function MakeStr(ch : char; sz : byte ) : shortstring;
begin
result[0 ]:=char(sz );
fillchar(result[1 ] ,sz ,ch );
end;
{ BACKLEN }
function BackLen(s : shortstring; sz : byte ) : shortstring;
type
tSCAN = (
SCAN_0 ,
SCAN_1 ,SCAN_2 ,SCAN_3 ,SCAN_4 ,SCAN_5 ,SCAN_6 ,SCAN_7 ,SCAN_8 ,SCAN_9 ,
SCAN_A ,SCAN_B ,SCAN_C ,SCAN_D ,SCAN_E ,SCAN_F ,SCAN_G ,SCAN_H ,SCAN_I ,
SCAN_J ,SCAN_K ,SCAN_L ,SCAN_M ,SCAN_N ,SCAN_O ,SCAN_P ,SCAN_Q ,SCAN_R ,
SCAN_S ,SCAN_T ,SCAN_U ,SCAN_V ,SCAN_W ,SCAN_X ,SCAN_Y ,SCAN_Z
);
var
pos ,
wcb : byte;
scn : tSCAN;
begin
result:='';
wcb:=sz;
pos:=length(s );
scn:=SCAN_1;
while wcb > 0 do
begin
case scn of
SCAN_1 :
if pos > 0 then
begin
result:=s[pos ] + result;
dec(pos );
end
else
begin
scn:=SCAN_2;
result:=' ' + result;
end;
SCAN_2 :
result:=' ' + result;
end;
dec(wcb );
end;
end;
{ INTHEX }
function IntHex(i : int64; max : byte = 0; do_low : boolean = false ) : shortstring;
type
tITEM = (
ITEM_0 ,
ITEM_1 ,ITEM_2 ,ITEM_3 ,ITEM_4 ,ITEM_5 ,ITEM_6 ,ITEM_7 ,ITEM_8 ,ITEM_9 ,
ITEM_A ,ITEM_B ,ITEM_C ,ITEM_D ,ITEM_E ,ITEM_F ,ITEM_G ,ITEM_H ,ITEM_I ,
ITEM_J ,ITEM_K ,ITEM_L ,ITEM_M ,ITEM_N ,ITEM_O ,ITEM_P ,ITEM_Q ,ITEM_R ,
ITEM_S ,ITEM_T ,ITEM_U ,ITEM_V ,ITEM_W ,ITEM_X ,ITEM_Y ,ITEM_Z
);
var
str : shortstring;
itm : tITEM;
fcb : byte;
const
low : array[0..$f ] of char = '0123456789abcdef';
hex : array[0..$f ] of char = '0123456789ABCDEF';
begin
if do_low then
str:=
low[i shr 60 and 15 ] +
low[i shr 56 and 15 ] +
low[i shr 52 and 15 ] +
low[i shr 48 and 15 ] +
low[i shr 44 and 15 ] +
low[i shr 40 and 15 ] +
low[i shr 36 and 15 ] +
low[i shr 32 and 15 ] +
low[i shr 28 and 15 ] +
low[i shr 24 and 15 ] +
low[i shr 20 and 15 ] +
low[i shr 16 and 15 ] +
low[i shr 12 and 15 ] +
low[i shr 8 and 15 ] +
low[i shr 4 and 15 ] +
low[i and 15 ]
else
str:=
hex[i shr 60 and 15 ] +
hex[i shr 56 and 15 ] +
hex[i shr 52 and 15 ] +
hex[i shr 48 and 15 ] +
hex[i shr 44 and 15 ] +
hex[i shr 40 and 15 ] +
hex[i shr 36 and 15 ] +
hex[i shr 32 and 15 ] +
hex[i shr 28 and 15 ] +
hex[i shr 24 and 15 ] +
hex[i shr 20 and 15 ] +
hex[i shr 16 and 15 ] +
hex[i shr 12 and 15 ] +
hex[i shr 8 and 15 ] +
hex[i shr 4 and 15 ] +
hex[i and 15 ];
if max > 0 then
if length(str ) > max then
result:=BackLen(str ,max )
else
if length(str ) < max then
result:=MakeStr('0' ,max - length(str ) ) + str
else
result:=str
else
begin
result:='';
itm:=ITEM_1;
for fcb:=1 to length(str ) do
case itm of
ITEM_1 :
case str[fcb ] of
'0' :
else
begin
result:=str[fcb ];
itm:=ITEM_2;
end;
end;
ITEM_2 :
result:=result + str[fcb ];
end;
if result = '' then
result:='0';
end;
end;
{ SPRINTF }
procedure sprintf;
type
scan = (_string ,_flags ,_width ,_precision ,_prefix ,_type );
var
sc : scan;
nt ,
fr : integer;
get : shortstring;
flg : char;
dth ,
prc ,
err : integer;
prf : array[0..3 ] of char;
typ : char;
{ apply }
procedure apply;
var
i ,x : int;
add : shortstring;
begin
add:='';
case typ of
'X' :
begin
if dth = 1 then
dth:=0;
add:=IntHex(trunc(val ) ,dth ,false );
end;
'x' :
begin
if dth = 1 then
dth:=0;
add:=IntHex(trunc(val ) ,dth ,true );
end;
's' :
add:=PChar(trunc(val ) );
'u' ,'d' :
begin
str(nt ,get );
while length(get ) < dth do
get:='0' + get;
add:=get;
end;
'f' :
begin
str(nt ,get );
while length(get ) < dth do
get:=' ' + get;
add:=get;
if prc > 0 then
begin
x:=1;
for i:=1 to prc do
x:=x * 10;
fr:=Abs(trunc(system.frac(val ) * x ) );
str(fr ,get );
while length(get ) < prc do
get:='0' + get;
add:=add + '.' + get;
end;
if (val < 0 ) and
(add[1 ] <> '-' ) then
add:='-' + add;
end;
end;
err:=0;
while err < length(add ) do
begin
dst^:=add[err + 1 ];
inc(ptrcomp(dst ) );
inc(err );
end;
sc:=_string;
end;
begin
nt:=trunc(system.int (val ) );
fr:=trunc(system.frac(val ) );
sc:=_string;
flg:=#0;
dth:=1;
prc:=0;
prf:=#0;
typ:='s';
while src^ <> #0 do
begin
case sc of
{ Copy Text or expect % }
_string :
case src^ of
'%' :
sc:=_flags;
else
begin
dst^:=src^;
inc(ptrcomp(dst ) );
end;
end;
{ Flags }
_flags :
case src^ of
'-' ,'+' ,'0' ,' ' ,'#' :
begin
flg:=src^;
if flg=#0 then ; // ToDo
end;
'1'..'9' :
begin
get:=src^;
sc :=_width;
end;
'.' :
begin
get:='';
sc :=_precision;
end;
'h' ,'l' :
begin
prf[0 ]:=src^;
prf[3 ]:=#1;
sc:=_type;
end;
'I' :
begin
prf[0 ]:=src^;
prf[3 ]:=#1;
sc:=_prefix;
end;
'c' ,'C' ,'d' ,'i' ,'o' ,'u' ,'x' ,'X' ,'e' ,'E' ,'f' ,'g' ,'G' ,'n' ,'p' ,'s' ,'S' :
begin
typ:=src^;
apply;
end;
else
begin
dst^:=src^;
inc(ptrcomp(dst ) );
sc:=_string;
end;
end;
{ Width }
_width :
case src^ of
'0' ,'1'..'9' :
get:=get + src^;
else
begin
system.val(get ,dth ,err );
case src^ of
'.' :
begin
get:='';
sc :=_precision;
end;
'h' ,'l' :
begin
prf[0 ]:=src^;
prf[3 ]:=#1;
sc:=_type;
end;
'I' :
begin
prf[0 ]:=src^;
prf[3 ]:=#1;
sc:=_prefix;
end;
'c' ,'C' ,'d' ,'i' ,'o' ,'u' ,'x' ,'X' ,'e' ,'E' ,'f' ,'g' ,'G' ,'n' ,'p' ,'s' ,'S' :
begin
typ:=src^;
apply;
end;
else
sc:=_string;
end;
end;
end;
{ Precision }
_precision :
case src^ of
'0' ,'1'..'9' :
get:=get + src^;
else
begin
system.val(get ,prc ,err );
case src^ of
'h' ,'l' :
begin
prf[0 ]:=src^;
prf[3 ]:=#1;
sc:=_type;
end;
'I' :
begin
prf[0 ]:=src^;
prf[3 ]:=#1;
sc:=_prefix;
end;
'c' ,'C' ,'d' ,'i' ,'o' ,'u' ,'x' ,'X' ,'e' ,'E' ,'f' ,'g' ,'G' ,'n' ,'p' ,'s' ,'S' :
begin
typ:=src^;
apply;
end;
else
sc:=_string;
end;
end;
end;
{ Prefix }
_prefix :
if prf[3 ] = #1 then
case src^ of
'3' ,'6' :
begin
prf[1 ]:=src^;
prf[3 ]:=#2;
end;
'c' ,'C' ,'d' ,'i' ,'o' ,'u' ,'x' ,'X' ,'e' ,'E' ,'f' ,'g' ,'G' ,'n' ,'p' ,'s' ,'S' :
begin
typ:=src^;
apply;
end;
else
sc:=_string;
end
else
if prf[3 ] = #2 then
case src^ of
'2' ,'4' :
begin
prf[2 ]:=src^;
prf[3 ]:=#3;
sc:=_type;
end;
'c' ,'C' ,'d' ,'i' ,'o' ,'u' ,'x' ,'X' ,'e' ,'E' ,'f' ,'g' ,'G' ,'n' ,'p' ,'s' ,'S' :
begin
typ:=src^;
apply;
end;
else
sc:=_string;
end
else
sc:=_string;
{ Type }
_type :
case src^ of
'c' ,'C' ,'d' ,'i' ,'o' ,'u' ,'x' ,'X' ,'e' ,'E' ,'f' ,'g' ,'G' ,'n' ,'p' ,'s' ,'S' :
begin
typ:=src^;
apply;
end;
else
sc:=_string;
end;
end;
inc(ptrcomp(src ) );
end;
dst^:=#0;
end;
{ INTDBL }
function intdbl;
begin
result:=i;
end;
{ SRAND_ }
procedure srand_(seed : int );
begin
system.RandSeed:=seed;
end;
{ RAND_ }
// Generates a pseudorandom number
function rand_ : int;
begin
result:=system.Random($7fff )
end;
var
g_holdrand : int = 1;
{ SRAND }
procedure srand(seed : int );
begin
g_holdrand:=seed;
end;
{ RAND }
function rand : int;
begin
g_holdrand:=g_holdrand * 214013 + 2531011;
result:=(shr_int32(g_holdrand ,16 ) and $7fff );
end;
{ UROUND }
function uround(v : double ) : int;
begin
result:=unsigned(Trunc(v + 0.5 ) );
end;
{ IROUND }
function iround(v : double ) : int;
begin
if v < 0.0 then
result:=int(Trunc(v - 0.5 ) )
else
result:=int(Trunc(v + 0.5 ) );
end;
{ SATURATION_IROUND }
function saturation_iround(Limit : int; v : double ) : int;
begin
if v < -Limit then
result:=-Limit
else
if v > Limit then
result:=Limit
else
result:=iround(v );
end;
{ NoP }
procedure NoP;
begin
end;
{ SHR_INT8 }
function shr_int8(i ,shift : int8 ) : int8;
begin
Result := SarShortint(i, shift);
end;
{ SHR_INT16 }
function shr_int16(i ,shift : int16 ) : int16;
begin
Result := SarSmallint(i, shift);
end;
{ SHR_INT32 }
function shr_int32(i, shift: int): int;
begin
Result := SarLongint(i, shift);
end;
end.