我要状告 Baidu ,在我公布我做出搜索引擎之后, Baidu派其蜘蛛抓去了,我网站上所有的链接!(1分)

  • 主题发起人 主题发起人 dcms
  • 开始时间 开始时间
D

dcms

Unregistered / Unconfirmed
GUEST, unregistred user!
我要状告 Baidu ,在我公布我做出搜索引擎之后, Baidu派其蜘蛛抓去了,我网站上所有的链接!
我来自: http://www.dcmscn.cn
下面是证据:
标识 用户名 当前位置 用户信息 来源鉴定 在线和不活动时间
客人 Delphi书籍资料-Delphi书籍资料-论坛展区错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:6m
客人 站务管理-站务管理-论坛展区错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:6m
客人 休闲娱乐组-休闲娱乐组-论坛展区错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:6m
客人 Delphi控件-Delphi控件-论坛用户组权限查询错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:5m
客人 站务中心-站务中心-论坛展区错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:4m
客人 .net书籍资料-.net书籍资料-论坛用户组权限查询错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:4m
客人 电子地图 Windows 98,IE 5.5 61.144.173.139 10m | 46h:53m
客人 Sql Server技术交流-Sql Server技术交流-论坛搜索错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:3m
客人 免费在线电影 Windows XP,IE 6.0 222.188.187.65 0m | 47h:2m
客人 .NET技术交流-.NET技术交流-事件记录列表错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:2m
客人 ■ Flash·音乐-■ Flash·音乐-论坛展区错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:2m
客人 .NET技术交流-.NET技术交流-论坛展区错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:2m
客人 .NET控件-.NET控件-论坛搜索错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:2m
客人 Delphi控件-Delphi控件-事件记录列表错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:1m
客人 站务中心-站务中心-论坛搜索错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:1m
客人 .net书籍资料-.net书籍资料-论坛展区错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:1m
客人 ■ Flash·音乐-■ Flash·音乐-事件记录列表错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:1m
客人 Delphi控件-Delphi控件-论坛搜索错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:1m
客人 站务管理-站务管理-论坛搜索错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:1m
客人 站务管理-站务管理-论坛用户组权限查询错误信息 Baiduspider搜索器, 202.108.23.72 0m | 47h:0m
 
//-------------------------------------------------------------
//
// Borland Delphi Runtime Library
// <API> interface unit
//
// Portions created by Microsoft are
// Copyright (C) 1995-1999 Microsoft Corporation.
// All Rights Reserved.
//
// The original file is: Winsock2.h from CBuilder5 distribution.
// The original Pascal code is: winsock2.pas, released 04 Mar 2000.
// The initial developer of the Pascal code is Alex Konshin
// (alexk@mtgroup.ru).
//
// Portions created by Alex Konshin are
// Copyright (C) 1998-2000 Alex Konshin
//
// Contributor(s): Alex Konshin
//
// Obtained through:
//
// Joint Endeavour of Delphi Innovators (Project JEDI)
//
// You may retrieve the latest version of this file at the Project
// JEDI home page, located at http://delphi-jedi.org
//
// The contents of this file are used with permission, subject to
// the Mozilla Public License Version 1.1 (the "License");
you may
// not use this file except in compliance with the License. You may
// obtain a copy of the License at
// http://www.mozilla.org/MPL/MPL-1.1.html
//
// Software distributed under the License is distributed on an
// "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
// implied. See the License for the specific language governing
// rights and limitations under the License.
//
//-------------------------------------------------------------
{ Winsock2.h -- definitions to be used with the WinSock 2 DLL and WinSock 2 applications.
This header file corresponds to version 2.2.x of the WinSock API specification.
This file includes parts which are Copyright (c) 1982-1986 Regents
of the University of California. All rights reserved.
The Berkeley Software License Agreement specifies the terms and
conditions for redistribution. }
// converted by Alex Konshin, mailto:alexk@mtgroup.ru
// modified March,4 2000
unit WinSock2;
interface
uses SysUtils, Windows;
{$ALIGN OFF}
{$RANGECHECKS OFF}
{$WRITEABLECONST OFF}
// Define the current Winsock version. To build an earlier Winsock version
// application redefine this value prior to including Winsock2.h
const
WINSOCK_VERSION = $0202;
WINSOCK2_DLL = 'ws2_32.dll';
type
u_char = Byte;
u_short = Word;
u_int = DWORD;
u_long = DWORD;
// The new type to be used in all instances which refer to sockets.
TSocket = u_int;
WSAEVENT = THandle;
PWSAEVENT = ^WSAEVENT;
LPWSAEVENT = PWSAEVENT;
{$IFDEF UNICODE}
PMBChar = PWideChar;
{$else
}
PMBChar = PChar;
{$ENDIF}
const
FD_SETSIZE = 64;
type
PFDSet = ^TFDSet;
TFDSet = packed record
fd_count: u_int;
fd_array: array[0..FD_SETSIZE - 1] of TSocket;
end;

PTimeVal = ^TTimeVal;
TTimeVal = packed record
tv_sec: Longint;
tv_usec: Longint;
end;

const
IOCPARM_MASK = $7F;
IOC_VOID = $20000000;
IOC_OUT = $40000000;
IOC_IN = $80000000;
IOC_INOUT = (IOC_IN or IOC_OUT);
// get # bytes to read
FIONREAD = IOC_OUT or (SizeOf(Longint) shl 16) or (Ord('f') shl 8) or 127;
// set/clear non-blocking i/o
FIONBIO = IOC_IN or (SizeOf(Longint) shl 16) or (Ord('f') shl 8) or 126;
// set/clear async i/o
FIOASYNC = IOC_IN or (SizeOf(Longint) shl 16) or (Ord('f') shl 8) or 125;
// Socket I/O Controls
// set high watermark
SIOCSHIWAT = IOC_IN or (SizeOf(Longint) shl 16) or (Ord('s') shl 8);
// get high watermark
SIOCGHIWAT = IOC_OUT or (SizeOf(Longint) shl 16) or (Ord('s') shl 8) or 1;
// set low watermark
SIOCSLOWAT = IOC_IN or (SizeOf(Longint) shl 16) or (Ord('s') shl 8) or 2;
// get low watermark
SIOCGLOWAT = IOC_OUT or (SizeOf(Longint) shl 16) or (Ord('s') shl 8) or 3;
// at oob mark?
SIOCATMARK = IOC_OUT or (SizeOf(Longint) shl 16) or (Ord('s') shl 8) or 7;
// Structures returned by network data base library, taken from the
// BSD file netdb.h. All addresses are supplied in host order, and
// returned in network order (suitable for use in system calls).
type
PHostEnt = ^THostEnt;
THostEnt = packed record
h_name: PChar;
// official name of host
h_aliases: ^PChar;
// alias list
h_addrtype: Smallint;
// host address type
h_length: Smallint;
// length of address
case Byte of
0: (h_addr_list: ^PChar);
// list of addresses
1: (h_addr: ^PChar);
// address, for backward compat
end;

// It is assumed here that a network number
// fits in 32 bits.
PNetEnt = ^TNetEnt;
TNetEnt = packed record
n_name: PChar;
// official name of net
n_aliases: ^PChar;
// alias list
n_addrtype: Smallint;
// net address type
n_net: u_long;
// network #
end;

PServEnt = ^TServEnt;
TServEnt = packed record
s_name: PChar;
// official service name
s_aliases: ^PChar;
// alias list
s_port: Smallint;
// protocol to use
s_proto: PChar;
// port #
end;

PProtoEnt = ^TProtoEnt;
TProtoEnt = packed record
p_name: PChar;
// official protocol name
p_aliases: ^Pchar;
// alias list
p_proto: Smallint;
// protocol #
end;

// Constants and structures defined by the internet system,
// Per RFC 790, September 1981, taken from the BSD file netinet/in.h.
const
// Protocols
IPPROTO_IP = 0;
// dummy for IP
IPPROTO_ICMP = 1;
// control message protocol
IPPROTO_IGMP = 2;
// group management protocol
IPPROTO_GGP = 3;
// gateway^2 (deprecated)
IPPROTO_TCP = 6;
// TCP
IPPROTO_PUP = 12;
// pup
IPPROTO_UDP = 17;
// UDP - user datagram protocol
IPPROTO_IDP = 22;
// xns idp
IPPROTO_ND = 77;
// UNOFFICIAL net disk proto
IPPROTO_RAW = 255;
// raw IP packet
IPPROTO_MAX = 256;
// Port/socket numbers: network standard functions
IPPORT_ECHO = 7;
IPPORT_DISCARD = 9;
IPPORT_SYSTAT = 11;
IPPORT_DAYTIME = 13;
IPPORT_NETSTAT = 15;
IPPORT_FTP = 21;
IPPORT_TELNET = 23;
IPPORT_SMTP = 25;
IPPORT_TIMESERVER = 37;
IPPORT_NAMESERVER = 42;
IPPORT_WHOIS = 43;
IPPORT_MTP = 57;
// Port/socket numbers: host specific functions
IPPORT_TFTP = 69;
IPPORT_RJE = 77;
IPPORT_FINGER = 79;
IPPORT_TTYLINK = 87;
IPPORT_SUPDUP = 95;
// UNIX TCP sockets
IPPORT_EXECSERVER = 512;
IPPORT_LOGINSERVER = 513;
IPPORT_CMDSERVER = 514;
IPPORT_EFSSERVER = 520;
// UNIX UDP sockets
IPPORT_BIFFUDP = 512;
IPPORT_WHOSERVER = 513;
IPPORT_ROUTESERVER = 520;
// Ports < IPPORT_RESERVED are reserved for privileged processes (e.g. root).
IPPORT_RESERVED = 1024;
// Link numbers
IMPLINK_IP = 155;
IMPLINK_LOWEXPER = 156;
IMPLINK_HIGHEXPER = 158;
TF_DISCONNECT = $01;
TF_REUSE_SOCKET = $02;
TF_WRITE_BEHIND = $04;
// This is used instead of -1, since the TSocket type is unsigned.
INVALID_SOCKET = TSocket(not (0));
SOCKET_ERROR = -1;
// The following may be used in place of the address family, socket type, or
// protocol in a call to WSASocket to indicate that the corresponding value
// should be taken from the supplied WSAPROTOCOL_INFO structure instead of the
// parameter itself.
FROM_PROTOCOL_INFO = -1;
// Types
SOCK_STREAM = 1;
{ stream socket }
SOCK_DGRAM = 2;
{ datagram socket }
SOCK_RAW = 3;
{ raw-protocol interface }
SOCK_RDM = 4;
{ reliably-delivered message }
SOCK_SEQPACKET = 5;
{ sequenced packet stream }
// Option flags per-socket.
SO_DEBUG = $0001;
// turn on debugging info recording
SO_ACCEPTCONN = $0002;
// socket has had listen()
SO_REUSEADDR = $0004;
// allow local address reuse
SO_KEEPALIVE = $0008;
// keep connections alive
SO_DONTROUTE = $0010;
// just use interface addresses
SO_BROADCAST = $0020;
// permit sending of broadcast msgs
SO_USELOOPBACK = $0040;
// bypass hardware when possible
SO_LINGER = $0080;
// linger on close if data present
SO_OOBINLINE = $0100;
// leave received OOB data in line
SO_DONTLINGER = not SO_LINGER;
SO_EXCLUSIVEADDRUSE = not SO_REUSEADDR;
// disallow local address reuse
// Additional options.
SO_SNDBUF = $1001;
// send buffer size
SO_RCVBUF = $1002;
// receive buffer size
SO_SNDLOWAT = $1003;
// send low-water mark
SO_RCVLOWAT = $1004;
// receive low-water mark
SO_SNDTIMEO = $1005;
// send timeout
SO_RCVTIMEO = $1006;
// receive timeout
SO_ERROR = $1007;
// get error status and clear
SO_TYPE = $1008;
// get socket type
// Options for connect and disconnect data and options.
// Used only by non-TCP/IP transports such as DECNet, OSI TP4, etc.
SO_CONNDATA = $7000;
SO_CONNOPT = $7001;
SO_DISCDATA = $7002;
SO_DISCOPT = $7003;
SO_CONNDATALEN = $7004;
SO_CONNOPTLEN = $7005;
SO_DISCDATALEN = $7006;
SO_DISCOPTLEN = $7007;
// Option for opening sockets for synchronous access.
SO_OPENTYPE = $7008;
SO_SYNCHRONOUS_ALERT = $10;
SO_SYNCHRONOUS_NONALERT = $20;
// Other NT-specific options.
SO_MAXDG = $7009;
SO_MAXPATHDG = $700A;
SO_UPDATE_ACCEPT_CONTEXT = $700B;
SO_CONNECT_TIME = $700C;
// TCP options.
TCP_NODELAY = $0001;
TCP_BSDURGENT = $7000;
// WinSock 2 extension -- new options
SO_GROUP_ID = $2001;
// ID of a socket group
SO_GROUP_PRIORITY = $2002;
// the relative priority within a group
SO_MAX_MSG_SIZE = $2003;
// maximum message size
SO_Protocol_InfoA = $2004;
// WSAPROTOCOL_INFOA structure
SO_Protocol_InfoW = $2005;
// WSAPROTOCOL_INFOW structure
{$IFDEF UNICODE}
SO_Protocol_Info = SO_Protocol_InfoW;
{$else
}
SO_Protocol_Info = SO_Protocol_InfoA;
{$ENDIF}
PVD_CONFIG = $3001;
// configuration info for service provider
SO_CONDITIONAL_ACCEPT = $3002;
// enable true conditional accept:
// connection is not ack-ed to the
// other side until conditional
// function returns CF_ACCEPT
// Address families.
AF_UNSPEC = 0;
// unspecified
AF_UNIX = 1;
// local to host (pipes, portals)
AF_INET = 2;
// internetwork: UDP, TCP, etc.
AF_IMPLINK = 3;
// arpanet imp addresses
AF_PUP = 4;
// pup protocols: e.g. BSP
AF_CHAOS = 5;
// mit CHAOS protocols
AF_IPX = 6;
// IPX and SPX
AF_NS = AF_IPX;
// XEROX NS protocols
AF_ISO = 7;
// ISO protocols
AF_OSI = AF_ISO;
// OSI is ISO
AF_ECMA = 8;
// european computer manufacturers
AF_DATAKIT = 9;
// datakit protocols
AF_CCITT = 10;
// CCITT protocols, X.25 etc
AF_SNA = 11;
// IBM SNA
AF_DECnet = 12;
// DECnet
AF_DLI = 13;
// Direct data link interface
AF_LAT = 14;
// LAT
AF_HYLINK = 15;
// NSC Hyperchannel
AF_APPLETALK = 16;
// AppleTalk
AF_NETBIOS = 17;
// NetBios-style addresses
AF_VOICEVIEW = 18;
// VoiceView
AF_FIREFOX = 19;
// FireFox
AF_UNKNOWN1 = 20;
// Somebody is using this!
AF_BAN = 21;
// Banyan
AF_ATM = 22;
// Native ATM Services
AF_INET6 = 23;
// Internetwork Version 6
AF_CLUSTER = 24;
// Microsoft Wolfpack
AF_12844 = 25;
// IEEE 1284.4 WG AF
AF_IRDA = 26;
// IrDA
AF_NETDES = 28;
// Network Designers OSI & gateway enabled protocols
AF_MAX = 29;
// Protocol families, same as address families for now.
PF_UNSPEC = AF_UNSPEC;
PF_UNIX = AF_UNIX;
PF_INET = AF_INET;
PF_IMPLINK = AF_IMPLINK;
PF_PUP = AF_PUP;
PF_CHAOS = AF_CHAOS;
PF_NS = AF_NS;
PF_IPX = AF_IPX;
PF_ISO = AF_ISO;
PF_OSI = AF_OSI;
PF_ECMA = AF_ECMA;
PF_DATAKIT = AF_DATAKIT;
PF_CCITT = AF_CCITT;
PF_SNA = AF_SNA;
PF_DECnet = AF_DECnet;
PF_DLI = AF_DLI;
PF_LAT = AF_LAT;
PF_HYLINK = AF_HYLINK;
PF_APPLETALK = AF_APPLETALK;
PF_VOICEVIEW = AF_VOICEVIEW;
PF_FIREFOX = AF_FIREFOX;
PF_UNKNOWN1 = AF_UNKNOWN1;
PF_BAN = AF_BAN;
PF_ATM = AF_ATM;
PF_INET6 = AF_INET6;
PF_MAX = AF_MAX;
type
SunB = packed record
s_b1, s_b2, s_b3, s_b4: u_char;
end;

SunW = packed record
s_w1, s_w2: u_short;
end;

TInAddr = packed record
case integer of
0: (S_un_b: SunB);
1: (S_un_w: SunW);
2: (S_addr: u_long);
end;
PInAddr = ^TInAddr;
// Structure used by kernel to store most addresses.
TSockAddrIn = packed record
case Integer of
0: (sin_family: u_short;
sin_port: u_short;
sin_addr: TInAddr;
sin_zero: array[0..7] of Char);
1: (sa_family: u_short;
sa_data: array[0..13] of Char)
end;
PSockAddrIn = ^TSockAddrIn;
TSockAddr = TSockAddrIn;
PSockAddr = ^TSockAddr;
SOCKADDR = TSockAddr;
SOCKADDR_IN = TSockAddrIn;
// Structure used by kernel to pass protocol information in raw sockets.
PSockProto = ^TSockProto;
TSockProto = packed record
sp_family: u_short;
sp_protocol: u_short;
end;

// Structure used for manipulating linger option.
PLinger = ^TLinger;
TLinger = packed record
l_onoff: u_short;
l_linger: u_short;
end;

const
INADDR_ANY = $00000000;
INADDR_LOOPBACK = $7F000001;
INADDR_BROADCAST = $FFFFFFFF;
INADDR_NONE = $FFFFFFFF;
ADDR_ANY = INADDR_ANY;
SOL_SOCKET = $FFFF;
// options for socket level
MSG_OOB = $1;
// process out-of-band data
MSG_PEEK = $2;
// peek at incoming message
MSG_DONTROUTE = $4;
// send without using routing tables
MSG_PARTIAL = $8000;
// partial send or recv for message xport
// WinSock 2 extension -- new flags for WSASend(), WSASendTo(), WSARecv() and WSARecvFrom()
MSG_INTERRUPT = $10;
// send/recv in the interrupt context
MSG_MAXIOVLEN = 16;
// Define constant based on rfc883, used by gethostbyxxxx() calls.
MAXGETHOSTSTRUCT = 1024;
// Maximum queue length specifiable by listen.
SOMAXCONN = $7FFFFFFF;
// WinSock 2 extension -- bit values and indices for FD_XXX network events
FD_READ_BIT = 0;
FD_WRITE_BIT = 1;
FD_OOB_BIT = 2;
FD_ACCEPT_BIT = 3;
FD_CONNECT_BIT = 4;
FD_CLOSE_BIT = 5;
FD_QOS_BIT = 6;
FD_GROUP_QOS_BIT = 7;
FD_MAX_EVENTS = 8;
FD_READ = (1 shl FD_READ_BIT);
FD_WRITE = (1 shl FD_WRITE_BIT);
FD_OOB = (1 shl FD_OOB_BIT);
FD_ACCEPT = (1 shl FD_ACCEPT_BIT);
FD_CONNECT = (1 shl FD_CONNECT_BIT);
FD_CLOSE = (1 shl FD_CLOSE_BIT);
FD_QOS = (1 shl FD_QOS_BIT);
FD_GROUP_QOS = (1 shl FD_GROUP_QOS_BIT);
FD_ALL_EVENTS = (1 shl FD_MAX_EVENTS) - 1;
// All Windows Sockets error constants are biased by WSABASEERR from the "normal"
WSABASEERR = 10000;
// Windows Sockets definitions of regular Microsoft C error constants
WSAEINTR = WSABASEERR + 4;
WSAEBADF = WSABASEERR + 9;
WSAEACCES = WSABASEERR + 13;
WSAEFAULT = WSABASEERR + 14;
WSAEINVAL = WSABASEERR + 22;
WSAEMFILE = WSABASEERR + 24;
// Windows Sockets definitions of regular Berkeley error constants
WSAEWOULDBLOCK = WSABASEERR + 35;
WSAEINPROGRESS = WSABASEERR + 36;
WSAEALREADY = WSABASEERR + 37;
WSAENOTSOCK = WSABASEERR + 38;
WSAEDESTADDRREQ = WSABASEERR + 39;
WSAEMSGSIZE = WSABASEERR + 40;
WSAEPROTOTYPE = WSABASEERR + 41;
WSAENOPROTOOPT = WSABASEERR + 42;
WSAEPROTONOSUPPORT = WSABASEERR + 43;
WSAESOCKTNOSUPPORT = WSABASEERR + 44;
WSAEOPNOTSUPP = WSABASEERR + 45;
WSAEPFNOSUPPORT = WSABASEERR + 46;
WSAEAFNOSUPPORT = WSABASEERR + 47;
WSAEADDRINUSE = WSABASEERR + 48;
WSAEADDRNOTAVAIL = WSABASEERR + 49;
WSAENETDOWN = WSABASEERR + 50;
WSAENETUNREACH = WSABASEERR + 51;
WSAENETRESET = WSABASEERR + 52;
WSAECONNABORTED = WSABASEERR + 53;
WSAECONNRESET = WSABASEERR + 54;
WSAENOBUFS = WSABASEERR + 55;
WSAEISCONN = WSABASEERR + 56;
WSAENOTCONN = WSABASEERR + 57;
WSAESHUTDOWN = WSABASEERR + 58;
WSAETOOMANYREFS = WSABASEERR + 59;
WSAETIMEDOUT = WSABASEERR + 60;
WSAECONNREFUSED = WSABASEERR + 61;
WSAELOOP = WSABASEERR + 62;
WSAENAMETOOLONG = WSABASEERR + 63;
WSAEHOSTDOWN = WSABASEERR + 64;
WSAEHOSTUNREACH = WSABASEERR + 65;
WSAENOTEMPTY = WSABASEERR + 66;
WSAEPROCLIM = WSABASEERR + 67;
WSAEUSERS = WSABASEERR + 68;
WSAEDQUOT = WSABASEERR + 69;
WSAESTALE = WSABASEERR + 70;
WSAEREMOTE = WSABASEERR + 71;
// Extended Windows Sockets error constant definitions
WSASYSNOTREADY = WSABASEERR + 91;
WSAVERNOTSUPPORTED = WSABASEERR + 92;
WSANOTINITIALISED = WSABASEERR + 93;
WSAEDISCON = WSABASEERR + 101;
WSAENOMORE = WSABASEERR + 102;
WSAECANCELLED = WSABASEERR + 103;
WSAEINVALIDPROCTABLE = WSABASEERR + 104;
WSAEINVALIDPROVIDER = WSABASEERR + 105;
WSAEPROVIDERFAILEDINIT = WSABASEERR + 106;
WSASYSCALLFAILURE = WSABASEERR + 107;
WSASERVICE_NOT_FOUND = WSABASEERR + 108;
WSATYPE_NOT_FOUND = WSABASEERR + 109;
WSA_E_NO_MORE = WSABASEERR + 110;
WSA_E_CANCELLED = WSABASEERR + 111;
WSAEREFUSED = WSABASEERR + 112;
{ Error return codes from gethostbyname() and gethostbyaddr()
(when using the resolver). Note that these errors are
retrieved via WSAGetLastError() and must therefore follow
the rules for avoiding clashes with error numbers from
specific implementations or language run-time systems.
For this reason the codes are based at WSABASEERR+1001.
Note also that [WSA]NO_ADDRESS is defined only for
compatibility purposes. }
// Authoritative Answer: Host not found
WSAHOST_NOT_FOUND = WSABASEERR + 1001;
HOST_NOT_FOUND = WSAHOST_NOT_FOUND;
// Non-Authoritative: Host not found, or SERVERFAIL
WSATRY_AGAIN = WSABASEERR + 1002;
TRY_AGAIN = WSATRY_AGAIN;
// Non recoverable errors, FORMERR, REFUSED, NOTIMP
WSANO_RECOVERY = WSABASEERR + 1003;
NO_RECOVERY = WSANO_RECOVERY;
// Valid name, no data record of requested type
WSANO_DATA = WSABASEERR + 1004;
NO_DATA = WSANO_DATA;
// no address, look for MX record
WSANO_ADDRESS = WSANO_DATA;
NO_ADDRESS = WSANO_ADDRESS;
// Define QOS related error return codes
WSA_QOS_RECEIVERS = WSABASEERR + 1005;
// at least one Reserve has arrived
WSA_QOS_SENDERS = WSABASEERR + 1006;
// at least one Path has arrived
WSA_QOS_NO_SENDERS = WSABASEERR + 1007;
// there are no senders
WSA_QOS_NO_RECEIVERS = WSABASEERR + 1008;
// there are no receivers
WSA_QOS_REQUEST_CONFIRMED = WSABASEERR + 1009;
// Reserve has been confirmed
WSA_QOS_ADMISSION_FAILURE = WSABASEERR + 1010;
// error due to lack of resources
WSA_QOS_POLICY_FAILURE = WSABASEERR + 1011;
// rejected for administrative reasons - bad credentials
WSA_QOS_BAD_STYLE = WSABASEERR + 1012;
// unknown or conflicting style
WSA_QOS_BAD_OBJECT = WSABASEERR + 1013;
// problem with some part of the filterspec or providerspecific buffer in general
WSA_QOS_TRAFFIC_CTRL_ERROR = WSABASEERR + 1014;
// problem with some part of the flowspec
WSA_QOS_GENERIC_ERROR = WSABASEERR + 1015;
// general error
WSA_QOS_ESERVICETYPE = WSABASEERR + 1016;
// invalid service type in flowspec
WSA_QOS_EFLOWSPEC = WSABASEERR + 1017;
// invalid flowspec
WSA_QOS_EPROVSPECBUF = WSABASEERR + 1018;
// invalid provider specific buffer
WSA_QOS_EFILTERSTYLE = WSABASEERR + 1019;
// invalid filter style
WSA_QOS_EFILTERTYPE = WSABASEERR + 1020;
// invalid filter type
WSA_QOS_EFILTERCOUNT = WSABASEERR + 1021;
// incorrect number of filters
WSA_QOS_EOBJLENGTH = WSABASEERR + 1022;
// invalid object length
WSA_QOS_EFLOWCOUNT = WSABASEERR + 1023;
// incorrect number of flows
WSA_QOS_EUNKOWNPSOBJ = WSABASEERR + 1024;
// unknown object in provider specific buffer
WSA_QOS_EPOLICYOBJ = WSABASEERR + 1025;
// invalid policy object in provider specific buffer
WSA_QOS_EFLOWDESC = WSABASEERR + 1026;
// invalid flow descriptor in the list
WSA_QOS_EPSFLOWSPEC = WSABASEERR + 1027;
// inconsistent flow spec in provider specific buffer
WSA_QOS_EPSFILTERSPEC = WSABASEERR + 1028;
// invalid filter spec in provider specific buffer
WSA_QOS_ESDMODEOBJ = WSABASEERR + 1029;
// invalid shape discard mode object in provider specific buffer
WSA_QOS_ESHAPERATEOBJ = WSABASEERR + 1030;
// invalid shaping rate object in provider specific buffer
WSA_QOS_RESERVED_PETYPE = WSABASEERR + 1031;
// reserved policy element in provider specific buffer
{ WinSock 2 extension -- new error codes and type definition }
WSA_IO_PENDING = ERROR_IO_PENDING;
WSA_IO_INCOMPLETE = ERROR_IO_INCOMPLETE;
WSA_INVALID_HANDLE = ERROR_INVALID_HANDLE;
WSA_INVALID_PARAMETER = ERROR_INVALID_PARAMETER;
WSA_NOT_ENOUGH_MEMORY = ERROR_NOT_ENOUGH_MEMORY;
WSA_OPERATION_ABORTED = ERROR_OPERATION_ABORTED;
WSA_INVALID_EVENT = WSAEVENT(nil);
WSA_MAXIMUM_WAIT_EVENTS = MAXIMUM_WAIT_OBJECTS;
WSA_WAIT_FAILED = $FFFFFFFF;
WSA_WAIT_EVENT_0 = WAIT_OBJECT_0;
WSA_WAIT_IO_COMPLETION = WAIT_IO_COMPLETION;
WSA_WAIT_TIMEOUT = WAIT_TIMEOUT;
WSA_INFINITE = INFINITE;
{ Windows Sockets errors redefined as regular Berkeley error constants.
These are commented out in Windows NT to avoid conflicts with errno.h.
Use the WSA constants instead. }
EWOULDBLOCK = WSAEWOULDBLOCK;
EINPROGRESS = WSAEINPROGRESS;
EALREADY = WSAEALREADY;
ENOTSOCK = WSAENOTSOCK;
EDESTADDRREQ = WSAEDESTADDRREQ;
EMSGSIZE = WSAEMSGSIZE;
EPROTOTYPE = WSAEPROTOTYPE;
ENOPROTOOPT = WSAENOPROTOOPT;
EPROTONOSUPPORT = WSAEPROTONOSUPPORT;
ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT;
EOPNOTSUPP = WSAEOPNOTSUPP;
EPFNOSUPPORT = WSAEPFNOSUPPORT;
EAFNOSUPPORT = WSAEAFNOSUPPORT;
EADDRINUSE = WSAEADDRINUSE;
EADDRNOTAVAIL = WSAEADDRNOTAVAIL;
ENETDOWN = WSAENETDOWN;
ENETUNREACH = WSAENETUNREACH;
ENETRESET = WSAENETRESET;
ECONNABORTED = WSAECONNABORTED;
ECONNRESET = WSAECONNRESET;
ENOBUFS = WSAENOBUFS;
EISCONN = WSAEISCONN;
ENOTCONN = WSAENOTCONN;
ESHUTDOWN = WSAESHUTDOWN;
ETOOMANYREFS = WSAETOOMANYREFS;
ETIMEDOUT = WSAETIMEDOUT;
ECONNREFUSED = WSAECONNREFUSED;
ELOOP = WSAELOOP;
ENAMETOOLONG = WSAENAMETOOLONG;
EHOSTDOWN = WSAEHOSTDOWN;
EHOSTUNREACH = WSAEHOSTUNREACH;
ENOTEMPTY = WSAENOTEMPTY;
EPROCLIM = WSAEPROCLIM;
EUSERS = WSAEUSERS;
EDQUOT = WSAEDQUOT;
ESTALE = WSAESTALE;
EREMOTE = WSAEREMOTE;
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
TWSAData = packed record
wVersion: Word;
wHighVersion: Word;
szDescription: array[0..WSADESCRIPTION_LEN] of Char;
szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;

{ WSAOVERLAPPED = Record
Internal: LongInt;
InternalHigh: LongInt;
Offset: LongInt;
OffsetHigh: LongInt;
hEvent: WSAEVENT;
end;
}
WSAOVERLAPPED = TOverlapped;
TWSAOverlapped = WSAOverlapped;
PWSAOverlapped = ^WSAOverlapped;
LPWSAOVERLAPPED = PWSAOverlapped;
{ WinSock 2 extension -- WSABUF and QOS struct, include qos.h }
{ to pull in FLOWSPEC and related definitions }
WSABUF = packed record
len: U_LONG;
{ the length of the buffer }
buf: PChar;
{ the pointer to the buffer }
end {WSABUF};
PWSABUF = ^WSABUF;
LPWSABUF = PWSABUF;
TServiceType = LongInt;
TFlowSpec = packed record
TokenRate, // In Bytes/sec
TokenBucketSize, // In Bytes
PeakBandwidth, // In Bytes/sec
Latency, // In microseconds
DelayVariation: LongInt;
// In microseconds
ServiceType: TServiceType;
MaxSduSize, MinimumPolicedSize: LongInt;
// In Bytes
end;
PFlowSpec = ^TFLOWSPEC;
QOS = packed record
SendingFlowspec: TFlowSpec;
{ the flow spec for data sending }
ReceivingFlowspec: TFlowSpec;
{ the flow spec for data receiving }
ProviderSpecific: WSABUF;
{ additional provider specific stuff }
end;
TQualityOfService = QOS;
PQOS = ^QOS;
LPQOS = PQOS;
const
SERVICETYPE_NOTRAFFIC = $00000000;
// No data in this direction
SERVICETYPE_BESTEFFORT = $00000001;
// Best Effort
SERVICETYPE_CONTROLLEDLOAD = $00000002;
// Controlled Load
SERVICETYPE_GUARANTEED = $00000003;
// Guaranteed
SERVICETYPE_NETWORK_UNAVAILABLE = $00000004;
// Used to notify change to user
SERVICETYPE_GENERAL_INFORMATION = $00000005;
// corresponds to "General Parameters" defined by IntServ
SERVICETYPE_NOCHANGE = $00000006;
// used to indicate that the flow spec contains no change from any previous one
// to turn on immediate traffic control, OR this flag with the ServiceType field in teh FLOWSPEC
SERVICE_IMMEDIATE_TRAFFIC_CONTROL = $80000000;
// WinSock 2 extension -- manifest constants for return values of the condition function
CF_ACCEPT = $0000;
CF_REJECT = $0001;
CF_DEFER = $0002;
// WinSock 2 extension -- manifest constants for shutdown()
SD_RECEIVE = $00;
SD_SEND = $01;
SD_BOTH = $02;
// WinSock 2 extension -- data type and manifest constants for socket groups
SG_UNCONSTRAINED_GROUP = $01;
SG_CONSTRAINED_GROUP = $02;
type
GROUP = DWORD;
// WinSock 2 extension -- data type for WSAEnumNetworkEvents()
TWSANetworkEvents = record
lNetworkEvents: LongInt;
iErrorCode: array[0..FD_MAX_EVENTS - 1] of Integer;
end;
PWSANetworkEvents = ^TWSANetworkEvents;
LPWSANetworkEvents = PWSANetworkEvents;
// WinSock 2 extension -- WSAPROTOCOL_INFO structure
{$IFNDEF ver130}
TGUID = packed record
D1: LongInt;
D2: Word;
D3: Word;
D4: array[0..7] of Byte;
end;
PGUID = ^TGUID;
{$ENDIF}
LPGUID = PGUID;
// WinSock 2 extension -- WSAPROTOCOL_INFO manifest constants
const
MAX_PROTOCOL_CHAIN = 7;
BASE_PROTOCOL = 1;
LAYERED_PROTOCOL = 0;
WSAPROTOCOL_LEN = 255;
type
TWSAProtocolChain = record
ChainLen: Integer;
// the length of the chain,
// length = 0 means layered protocol,
// length = 1 means base protocol,
// length > 1 means protocol chain
ChainEntries: array[0..MAX_PROTOCOL_CHAIN - 1] of LongInt;
// a list of dwCatalogEntryIds
end;

type
TWSAProtocol_InfoA = record
dwServiceFlags1: LongInt;
dwServiceFlags2: LongInt;
dwServiceFlags3: LongInt;
dwServiceFlags4: LongInt;
dwProviderFlags: LongInt;
ProviderId: TGUID;
dwCatalogEntryId: LongInt;
ProtocolChain: TWSAProtocolChain;
iVersion: Integer;
iAddressFamily: Integer;
iMaxSockAddr: Integer;
iMinSockAddr: Integer;
iSocketType: Integer;
iProtocol: Integer;
iProtocolMaxOffset: Integer;
iNetworkByteOrder: Integer;
iSecurityScheme: Integer;
dwMessageSize: LongInt;
dwProviderReserved: LongInt;
szProtocol: array[0..WSAPROTOCOL_LEN + 1 - 1] of Char;
end {TWSAProtocol_InfoA};
PWSAProtocol_InfoA = ^TWSAProtocol_InfoA;
LPWSAProtocol_InfoA = PWSAProtocol_InfoA;
TWSAProtocol_InfoW = record
dwServiceFlags1: LongInt;
dwServiceFlags2: LongInt;
dwServiceFlags3: LongInt;
dwServiceFlags4: LongInt;
dwProviderFlags: LongInt;
ProviderId: TGUID;
dwCatalogEntryId: LongInt;
ProtocolChain: TWSAProtocolChain;
iVersion: Integer;
iAddressFamily: Integer;
iMaxSockAddr: Integer;
iMinSockAddr: Integer;
iSocketType: Integer;
iProtocol: Integer;
iProtocolMaxOffset: Integer;
iNetworkByteOrder: Integer;
iSecurityScheme: Integer;
dwMessageSize: LongInt;
dwProviderReserved: LongInt;
szProtocol: array[0..WSAPROTOCOL_LEN + 1 - 1] of WideChar;
end {TWSAProtocol_InfoW};
PWSAProtocol_InfoW = ^TWSAProtocol_InfoW;
LPWSAProtocol_InfoW = PWSAProtocol_InfoW;
{$IFDEF UNICODE}
WSAProtocol_Info = TWSAProtocol_InfoW;
TWSAProtocol_Info = TWSAProtocol_InfoW;
PWSAProtocol_Info = PWSAProtocol_InfoW;
LPWSAProtocol_Info = PWSAProtocol_InfoW;
{$else
}
WSAProtocol_Info = TWSAProtocol_InfoA;
TWSAProtocol_Info = TWSAProtocol_InfoA;
PWSAProtocol_Info = PWSAProtocol_InfoA;
LPWSAProtocol_Info = PWSAProtocol_InfoA;
{$ENDIF}
const
// Flag bit definitions for dwProviderFlags
PFL_MULTIPLE_PROTO_ENTRIES = $00000001;
PFL_RECOMMENDED_PROTO_ENTRY = $00000002;
PFL_HIDDEN = $00000004;
PFL_MATCHES_PROTOCOL_ZERO = $00000008;
// Flag bit definitions for dwServiceFlags1
XP1_CONNECTIONLESS = $00000001;
XP1_GUARANTEED_DELIVERY = $00000002;
XP1_GUARANTEED_ORDER = $00000004;
XP1_MESSAGE_ORIENTED = $00000008;
XP1_PSEUDO_STREAM = $00000010;
XP1_GRACEFUL_CLOSE = $00000020;
XP1_EXPEDITED_DATA = $00000040;
XP1_CONNECT_DATA = $00000080;
XP1_DISCONNECT_DATA = $00000100;
XP1_SUPPORT_BROADCAST = $00000200;
XP1_SUPPORT_MULTIPOINT = $00000400;
XP1_MULTIPOINT_CONTROL_PLANE = $00000800;
XP1_MULTIPOINT_DATA_PLANE = $00001000;
XP1_QOS_SUPPORTED = $00002000;
XP1_INTERRUPT = $00004000;
XP1_UNI_SEND = $00008000;
XP1_UNI_RECV = $00010000;
XP1_IFS_HANDLES = $00020000;
XP1_PARTIAL_MESSAGE = $00040000;
BIGENDIAN = $0000;
LITTLEENDIAN = $0001;
SECURITY_PROTOCOL_NONE = $0000;
// WinSock 2 extension -- manifest constants for WSAJoinLeaf()
JL_SENDER_ONLY = $01;
JL_RECEIVER_ONLY = $02;
JL_BOTH = $04;
// WinSock 2 extension -- manifest constants for WSASocket()
WSA_FLAG_OVERLAPPED = $01;
WSA_FLAG_MULTIPOINT_C_ROOT = $02;
WSA_FLAG_MULTIPOINT_C_LEAF = $04;
WSA_FLAG_MULTIPOINT_D_ROOT = $08;
WSA_FLAG_MULTIPOINT_D_LEAF = $10;
// WinSock 2 extension -- manifest constants for WSAIoctl()
IOC_UNIX = $00000000;
IOC_WS2 = $08000000;
IOC_PROTOCOL = $10000000;
IOC_VENDOR = $18000000;
SIO_ASSOCIATE_HANDLE = 1 or IOC_WS2 or IOC_IN;
SIO_ENABLE_CIRCULAR_QUEUEING = 2 or IOC_WS2;
SIO_FIND_ROUTE = 3 or IOC_WS2 or IOC_OUT;
SIO_FLUSH = 4 or IOC_WS2;
SIO_GET_BROADCAST_ADDRESS = 5 or IOC_WS2 or IOC_OUT;
SIO_GET_EXTENSION_FUNCTION_POINTER = 6 or IOC_WS2 or IOC_INOUT;
SIO_GET_QOS = 7 or IOC_WS2 or IOC_INOUT;
SIO_GET_GROUP_QOS = 8 or IOC_WS2 or IOC_INOUT;
SIO_MULTIPOINT_LOOPBACK = 9 or IOC_WS2 or IOC_IN;
SIO_MULTICAST_SCOPE = 10 or IOC_WS2 or IOC_IN;
SIO_SET_QOS = 11 or IOC_WS2 or IOC_IN;
SIO_SET_GROUP_QOS = 12 or IOC_WS2 or IOC_IN;
SIO_TRANSLATE_HANDLE = 13 or IOC_WS2 or IOC_INOUT;
SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT;
SIO_ROUTING_INTERFACE_CHANGE = 21 or IOC_WS2 or IOC_IN;
SIO_ADDRESS_LIST_QUERY = 22 or IOC_WS2 or IOC_OUT;
// see below SOCKET_ADDRESS_LIST
SIO_ADDRESS_LIST_CHANGE = 23 or IOC_WS2;
SIO_QUERY_TARGET_PNP_HANDLE = 24 or IOC_WS2 or IOC_OUT;
// WinSock 2 extension -- manifest constants for SIO_TRANSLATE_HANDLE ioctl
TH_NETDEV = $00000001;
TH_TAPI = $00000002;
type
// Manifest constants and type definitions related to name resolution and
// registration (RNR) API
TBLOB = packed record
cbSize: U_LONG;
pBlobData: PBYTE;
end;
PBLOB = ^TBLOB;
// Service Install Flags
const
SERVICE_MULTIPLE = $00000001;
// & Name Spaces
NS_ALL = 0;
NS_SAP = 1;
NS_NDS = 2;
NS_PEER_BROWSE = 3;
NS_TCPIP_LOCAL = 10;
NS_TCPIP_HOSTS = 11;
NS_DNS = 12;
NS_NETBT = 13;
NS_WINS = 14;
NS_NBP = 20;
NS_MS = 30;
NS_STDA = 31;
NS_NTDS = 32;
NS_X500 = 40;
NS_NIS = 41;
NS_NISPLUS = 42;
NS_WRQ = 50;
NS_NETDES = 60;
{ Resolution flags for WSAGetAddressByName().
Note these are also used by the 1.1 API GetAddressByName, so leave them around. }
RES_UNUSED_1 = $00000001;
RES_FLUSH_CACHE = $00000002;
RES_SERVICE = $00000004;
{ Well known value names for Service Types }
SERVICE_TYPE_VALUE_IPXPORTA = 'IpxSocket';
SERVICE_TYPE_VALUE_IPXPORTW: PWideChar = 'IpxSocket';
SERVICE_TYPE_VALUE_SAPIDA = 'SapId';
SERVICE_TYPE_VALUE_SAPIDW: PWideChar = 'SapId';
SERVICE_TYPE_VALUE_TCPPORTA = 'TcpPort';
SERVICE_TYPE_VALUE_TCPPORTW: PWideChar = 'TcpPort';
SERVICE_TYPE_VALUE_UDPPORTA = 'UdpPort';
SERVICE_TYPE_VALUE_UDPPORTW: PWideChar = 'UdpPort';
SERVICE_TYPE_VALUE_OBJECTIDA = 'ObjectId';
SERVICE_TYPE_VALUE_OBJECTIDW: PWideChar = 'ObjectId';
{$IFDEF UNICODE}
SERVICE_TYPE_VALUE_SAPID = SERVICE_TYPE_VALUE_SAPIDW;
SERVICE_TYPE_VALUE_TCPPORT = SERVICE_TYPE_VALUE_TCPPORTW;
SERVICE_TYPE_VALUE_UDPPORT = SERVICE_TYPE_VALUE_UDPPORTW;
SERVICE_TYPE_VALUE_OBJECTID = SERVICE_TYPE_VALUE_OBJECTIDW;
{$else
}
SERVICE_TYPE_VALUE_SAPID = SERVICE_TYPE_VALUE_SAPIDA;
SERVICE_TYPE_VALUE_TCPPORT = SERVICE_TYPE_VALUE_TCPPORTA;
SERVICE_TYPE_VALUE_UDPPORT = SERVICE_TYPE_VALUE_UDPPORTA;
SERVICE_TYPE_VALUE_OBJECTID = SERVICE_TYPE_VALUE_OBJECTIDA;
{$ENDIF}
// SockAddr Information
type
SOCKET_ADDRESS = packed record
lpSockaddr: PSockAddr;
iSockaddrLength: Integer;
end;
PSOCKET_ADDRESS = ^SOCKET_ADDRESS;
// CSAddr Information
CSADDR_INFO = packed record
LocalAddr, RemoteAddr: SOCKET_ADDRESS;
iSocketType, iProtocol: LongInt;
end;
PCSADDR_INFO = ^CSADDR_INFO;
LPCSADDR_INFO = ^CSADDR_INFO;
// Address list returned via WSAIoctl( SIO_ADDRESS_LIST_QUERY )
SOCKET_ADDRESS_LIST = packed record
iAddressCount: Integer;
Address: array[0..0] of SOCKET_ADDRESS;
end;
LPSOCKET_ADDRESS_LIST = ^SOCKET_ADDRESS_LIST;
// Address Family/Protocol Tuples
AFProtocols = record
iAddressFamily: Integer;
iProtocol: Integer;
end;
TAFProtocols = AFProtocols;
PAFProtocols = ^TAFProtocols;
// Client Query API Typedefs
// The comparators
TWSAEComparator = (COMP_EQUAL {= 0}, COMP_NOTLESS);
TWSAVersion = record
dwVersion: DWORD;
ecHow: TWSAEComparator;
end;
PWSAVersion = ^TWSAVersion;
TWSAQuerySetA = packed record
dwSize: DWORD;
lpszServiceInstanceName: PChar;
lpServiceClassId: PGUID;
lpVersion: PWSAVERSION;
lpszComment: PChar;
dwNameSpace: DWORD;
lpNSProviderId: PGUID;
lpszContext: PChar;
dwNumberOfProtocols: DWORD;
lpafpProtocols: PAFProtocols;
lpszQueryString: PChar;
dwNumberOfCsAddrs: DWORD;
lpcsaBuffer: PCSADDR_INFO;
dwOutputFlags: DWORD;
lpBlob: PBLOB;
end;
PWSAQuerySetA = ^TWSAQuerySetA;
LPWSAQuerySetA = PWSAQuerySetA;
TWSAQuerySetW = packed record
dwSize: DWORD;
lpszServiceInstanceName: PWideChar;
lpServiceClassId: PGUID;
lpVersion: PWSAVERSION;
lpszComment: PWideChar;
dwNameSpace: DWORD;
lpNSProviderId: PGUID;
lpszContext: PWideChar;
dwNumberOfProtocols: DWORD;
lpafpProtocols: PAFProtocols;
lpszQueryString: PWideChar;
dwNumberOfCsAddrs: DWORD;
lpcsaBuffer: PCSADDR_INFO;
dwOutputFlags: DWORD;
lpBlob: PBLOB;
end;
PWSAQuerySetW = ^TWSAQuerySetW;
LPWSAQuerySetW = PWSAQuerySetW;
{$IFDEF UNICODE}
TWSAQuerySet = TWSAQuerySetA;
PWSAQuerySet = PWSAQuerySetW;
LPWSAQuerySet = PWSAQuerySetW;
{$else
}
TWSAQuerySet = TWSAQuerySetA;
PWSAQuerySet = PWSAQuerySetA;
LPWSAQuerySet = PWSAQuerySetA;
{$ENDIF}
const
LUP_DEEP = $0001;
LUP_CONTAINERS = $0002;
LUP_NOCONTAINERS = $0004;
LUP_NEAREST = $0008;
LUP_RETURN_NAME = $0010;
LUP_RETURN_TYPE = $0020;
LUP_RETURN_VERSION = $0040;
LUP_RETURN_COMMENT = $0080;
LUP_RETURN_ADDR = $0100;
LUP_RETURN_BLOB = $0200;
LUP_RETURN_ALIASES = $0400;
LUP_RETURN_QUERY_STRING = $0800;
LUP_RETURN_ALL = $0FF0;
LUP_RES_SERVICE = $8000;
LUP_FLUSHCACHE = $1000;
LUP_FLUSHPREVIOUS = $2000;
// Return flags
RESULT_IS_ALIAS = $0001;
type
// Service Address Registration and Deregistration Data Types.
TWSAeSetServiceOp = (RNRSERVICE_REGISTER {=0}, RNRSERVICE_DEREGISTER,
RNRSERVICE_DELETE);
{ Service Installation/Removal Data Types. }
TWSANSClassInfoA = packed record
lpszName: PChar;
dwNameSpace: DWORD;
dwValueType: DWORD;
dwValueSize: DWORD;
lpValue: Pointer;
end;
PWSANSClassInfoA = ^TWSANSClassInfoA;
TWSANSClassInfoW = packed record
lpszName: PWideChar;
dwNameSpace: DWORD;
dwValueType: DWORD;
dwValueSize: DWORD;
lpValue: Pointer;
end {TWSANSClassInfoW};
PWSANSClassInfoW = ^TWSANSClassInfoW;
{$IFDEF UNICODE}
WSANSClassInfo = TWSANSClassInfoW;
TWSANSClassInfo = TWSANSClassInfoW;
PWSANSClassInfo = PWSANSClassInfoW;
LPWSANSClassInfo = PWSANSClassInfoW;
{$else
}
WSANSClassInfo = TWSANSClassInfoA;
TWSANSClassInfo = TWSANSClassInfoA;
PWSANSClassInfo = PWSANSClassInfoA;
LPWSANSClassInfo = PWSANSClassInfoA;
{$ENDIF // UNICODE}
TWSAServiceClassInfoA = packed record
lpServiceClassId: PGUID;
lpszServiceClassName: PChar;
dwCount: DWORD;
lpClassInfos: PWSANSClassInfoA;
end;
PWSAServiceClassInfoA = ^TWSAServiceClassInfoA;
LPWSAServiceClassInfoA = PWSAServiceClassInfoA;
TWSAServiceClassInfoW = packed record
lpServiceClassId: PGUID;
lpszServiceClassName: PWideChar;
dwCount: DWORD;
lpClassInfos: PWSANSClassInfoW;
end;
PWSAServiceClassInfoW = ^TWSAServiceClassInfoW;
LPWSAServiceClassInfoW = PWSAServiceClassInfoW;
{$IFDEF UNICODE}
WSAServiceClassInfo = TWSAServiceClassInfoW;
TWSAServiceClassInfo = TWSAServiceClassInfoW;
PWSAServiceClassInfo = PWSAServiceClassInfoW;
LPWSAServiceClassInfo = PWSAServiceClassInfoW;
{$else
}
WSAServiceClassInfo = TWSAServiceClassInfoA;
TWSAServiceClassInfo = TWSAServiceClassInfoA;
PWSAServiceClassInfo = PWSAServiceClassInfoA;
LPWSAServiceClassInfo = PWSAServiceClassInfoA;
{$ENDIF}
TWSANameSpace_InfoA = packed record
NSProviderId: TGUID;
dwNameSpace: DWORD;
fActive: DWORD {Bool};
dwVersion: DWORD;
lpszIdentifier: PChar;
end;
PWSANameSpace_InfoA = ^TWSANameSpace_InfoA;
LPWSANameSpace_InfoA = PWSANameSpace_InfoA;
TWSANameSpace_InfoW = packed record
NSProviderId: TGUID;
dwNameSpace: DWORD;
fActive: DWORD {Bool};
dwVersion: DWORD;
lpszIdentifier: PWideChar;
end {TWSANameSpace_InfoW};
PWSANameSpace_InfoW = ^TWSANameSpace_InfoW;
LPWSANameSpace_InfoW = PWSANameSpace_InfoW;
{$IFDEF UNICODE}
WSANameSpace_Info = TWSANameSpace_InfoW;
TWSANameSpace_Info = TWSANameSpace_InfoW;
PWSANameSpace_Info = PWSANameSpace_InfoW;
LPWSANameSpace_Info = PWSANameSpace_InfoW;
{$else
}
WSANameSpace_Info = TWSANameSpace_InfoA;
TWSANameSpace_Info = TWSANameSpace_InfoA;
PWSANameSpace_Info = PWSANameSpace_InfoA;
LPWSANameSpace_Info = PWSANameSpace_InfoA;
{$ENDIF}
{ WinSock 2 extensions -- data types for the condition function in }
{ WSAAccept() and overlapped I/O completion routine. }
type
LPCONDITIONPROC = function(lpCallerId: LPWSABUF;
lpCallerData: LPWSABUF;
lpSQOS, lpGQOS: LPQOS;
lpCalleeId, lpCalleeData: LPWSABUF;
g: GROUP;
dwCallbackData: DWORD): Integer;
stdcall;
LPWSAOVERLAPPED_COMPLETION_ROUTINE = procedure(const dwError, cbTransferred:
DWORD;
const lpOverlapped: LPWSAOVERLAPPED;
const dwFlags: DWORD);
stdcall;
function accept(const s: TSocket;
var addr: TSockAddr;
var addrlen: Integer):
TSocket;
stdcall;
function bind(const s: TSocket;
const addr: PSockAddr;
const namelen: Integer):
Integer;
stdcall;
function closesocket(const s: TSocket): Integer;
stdcall;
function connect(const s: TSocket;
const name: PSockAddr;
namelen: Integer):
Integer;
stdcall;
function ioctlsocket(const s: TSocket;
const cmd: DWORD;
var arg: u_long):
Integer;
stdcall;
function getpeername(const s: TSocket;
var name: TSockAddr;
var namelen:
Integer): Integer;
stdcall;
function getsockname(const s: TSocket;
var name: TSockAddr;
var namelen:
Integer): Integer;
stdcall;
function getsockopt(const s: TSocket;
const level, optname: Integer;
optval:
PChar;
var optlen: Integer): Integer;
stdcall;
function htonl(hostlong: u_long): u_long;
stdcall;
function htons(hostshort: u_short): u_short;
stdcall;
function inet_addr(cp: PChar): u_long;
stdcall;
function inet_ntoa(inaddr: TInAddr): PChar;
stdcall;
function listen(s: TSocket;
backlog: Integer): Integer;
stdcall;
function ntohl(netlong: u_long): u_long;
stdcall;
function ntohs(netshort: u_short): u_short;
stdcall;
function recv(s: TSocket;
var Buf;
len, flags: Integer): Integer;
stdcall;
function recvfrom(s: TSocket;
var Buf;
len, flags: Integer;
var from: TSockAddr;
var fromlen: Integer): Integer;
stdcall;
function select(nfds: Integer;
readfds, writefds, exceptfds: PFDSet;
timeout:
PTimeVal): Integer;
stdcall;
function send(s: TSocket;
var Buf;
len, flags: Integer): Integer;
stdcall;
function sendto(s: TSocket;
var Buf;
len, flags: Integer;
var addrto: TSockAddr;
tolen: Integer): Integer;
stdcall;
function setsockopt(s: TSocket;
level, optname: Integer;
optval: PChar;
optlen:
Integer): Integer;
stdcall;
function shutdown(s: TSocket;
how: Integer): Integer;
stdcall;
function socket(const af, struct, protocol: Integer): TSocket;
stdcall;
function gethostbyaddr(addr: Pointer;
len, struct: Integer): PHostEnt;
stdcall;
function gethostbyname(name: PChar): PHostEnt;
stdcall;
function gethostname(name: PChar;
len: Integer): Integer;
stdcall;
function getservbyport(port: Integer;
proto: PChar): PServEnt;
stdcall;
function getservbyname(const name, proto: PChar): PServEnt;
stdcall;
function getprotobynumber(const proto: Integer): PProtoEnt;
stdcall;
function getprotobyname(const name: PChar): PProtoEnt;
stdcall;
function WSAStartup(wVersionRequired: word;
var WSData: TWSAData): Integer;
stdcall;
function WSACleanup: Integer;
stdcall;
procedure WSASetLastError(iError: Integer);
stdcall;
function WSAGetLastError: Integer;
stdcall;
function WSAIsBlocking: BOOL;
stdcall;
function WSAUnhookBlockingHook: Integer;
stdcall;
function WSASetBlockingHook(lpBlockFunc: TFarProc): TFarProc;
stdcall;
function WSACancelBlockingCall: Integer;
stdcall;
function WSAAsyncGetServByName(HWindow: HWND;
wMsg: u_int;
name, proto, buf:
PChar;
buflen: Integer): THandle;
stdcall;
function WSAAsyncGetServByPort(HWindow: HWND;
wMsg, port: u_int;
proto, buf:
PChar;
buflen: Integer): THandle;
stdcall;
function WSAAsyncGetProtoByName(HWindow: HWND;
wMsg: u_int;
name, buf: PChar;
buflen: Integer): THandle;
stdcall;
function WSAAsyncGetProtoByNumber(HWindow: HWND;
wMsg: u_int;
number: Integer;
buf: PChar;
buflen: Integer): THandle;
stdcall;
function WSAAsyncGetHostByName(HWindow: HWND;
wMsg: u_int;
name, buf: PChar;
buflen: Integer): THandle;
stdcall;
function WSAAsyncGetHostByAddr(HWindow: HWND;
wMsg: u_int;
addr: PChar;
len,
struct: Integer;
buf: PChar;
buflen: Integer): THandle;
stdcall;
function WSACancelAsyncRequest(hAsyncTaskHandle: THandle): Integer;
stdcall;
function WSAAsyncSelect(s: TSocket;
HWindow: HWND;
wMsg: u_int;
lEvent:
Longint): Integer;
stdcall;
function __WSAFDIsSet(s: TSOcket;
var FDSet: TFDSet): Bool;
stdcall;
{ WinSock 2 API new function prototypes }
function WSAAccept(s: TSocket;
addr: TSockAddr;
addrlen: PInteger;
lpfnCondition: LPCONDITIONPROC;
dwCallbackData: DWORD): TSocket;
stdcall;
function WSACloseEvent(hEvent: WSAEVENT): WordBool;
stdcall;
function WSAConnect(s: TSocket;
const name: PSockAddr;
namelen: Integer;
lpCallerData, lpCalleeData: LPWSABUF;
lpSQOS, lpGQOS: LPQOS): Integer;
stdcall;
function WSACreateEvent: WSAEVENT;
stdcall;
function WSADuplicateSocketA(s: TSocket;
dwProcessId: DWORD;
lpProtocolInfo:
LPWSAProtocol_InfoA): Integer;
stdcall;
function WSADuplicateSocketW(s: TSocket;
dwProcessId: DWORD;
lpProtocolInfo:
LPWSAProtocol_InfoW): Integer;
stdcall;
function WSADuplicateSocket(s: TSocket;
dwProcessId: DWORD;
lpProtocolInfo:
LPWSAProtocol_Info): Integer;
stdcall;
function WSAEnumNetworkEvents(const s: TSocket;
const hEventObject: WSAEVENT;
lpNetworkEvents: LPWSANETWORKEVENTS): Integer;
stdcall;
function WSAEnumProtocolsA(lpiProtocols: PInteger;
lpProtocolBuffer:
LPWSAProtocol_InfoA;
var lpdwBufferLength: DWORD): Integer;
stdcall;
function WSAEnumProtocolsW(lpiProtocols: PInteger;
lpProtocolBuffer:
LPWSAProtocol_InfoW;
var lpdwBufferLength: DWORD): Integer;
stdcall;
function WSAEnumProtocols(lpiProtocols: PInteger;
lpProtocolBuffer:
LPWSAProtocol_Info;
var lpdwBufferLength: DWORD): Integer;
stdcall;
function WSAEventSelect(s: TSocket;
hEventObject: WSAEVENT;
lNetworkEvents:
LongInt): Integer;
stdcall;
function WSAGetOverlappedResult(s: TSocket;
lpOverlapped: LPWSAOVERLAPPED;
lpcbTransfer: LPDWORD;
fWait: BOOL;
var lpdwFlags: DWORD): WordBool;
stdcall;
function WSAGetQosByName(s: TSocket;
lpQOSName: LPWSABUF;
lpQOS: LPQOS):
WordBool;
stdcall;
function WSAhtonl(s: TSocket;
hostlong: u_long;
var lpnetlong: DWORD): Integer;
stdcall;
function WSAhtons(s: TSocket;
hostshort: u_short;
var lpnetshort: WORD):
Integer;
stdcall;
function WSAIoctl(s: TSocket;
dwIoControlCode: DWORD;
lpvInBuffer: Pointer;
cbInBuffer: DWORD;
lpvOutBuffer: Pointer;
cbOutBuffer: DWORD;
lpcbBytesReturned: LPDWORD;
lpOverlapped: LPWSAOVERLAPPED;
lpCompletionRoutine: LPWSAOVERLAPPED_COMPLETION_ROUTINE): Integer;
stdcall;
function WSAJoinLeaf(s: TSocket;
name: PSockAddr;
namelen: Integer;
lpCallerData, lpCalleeData: LPWSABUF;
lpSQOS, lpGQOS: LPQOS;
dwFlags: DWORD): TSocket;
stdcall;
function WSANtohl(s: TSocket;
netlong: u_long;
var lphostlong: DWORD): Integer;
stdcall;
function WSANtohs(s: TSocket;
netshort: u_short;
var lphostshort: WORD):
Integer;
stdcall;
function WSARecv(s: TSocket;
lpBuffers: LPWSABUF;
dwBufferCount: DWORD;
var
lpNumberOfBytesRecvd: DWORD;
var lpFlags: DWORD;
lpOverlapped: LPWSAOVERLAPPED;
lpCompletionRoutine:
LPWSAOVERLAPPED_COMPLETION_ROUTINE): Integer;
stdcall;
function WSARecvDisconnect(s: TSocket;
lpInboundDisconnectData: LPWSABUF):
Integer;
stdcall;
function WSARecvFrom(s: TSocket;
lpBuffers: LPWSABUF;
dwBufferCount: DWORD;
var
lpNumberOfBytesRecvd: DWORD;
var lpFlags: DWORD;
lpFrom: PSockAddr;
lpFromlen: PInteger;
lpOverlapped: LPWSAOVERLAPPED;
lpCompletionRoutine: LPWSAOVERLAPPED_COMPLETION_ROUTINE): Integer;
stdcall;
function WSAResetEvent(hEvent: WSAEVENT): WordBool;
stdcall;
function WSASend(s: TSocket;
lpBuffers: LPWSABUF;
dwBufferCount: DWORD;
var
lpNumberOfBytesSent: DWORD;
dwFlags: DWORD;
lpOverlapped: LPWSAOVERLAPPED;
lpCompletionRoutine:
LPWSAOVERLAPPED_COMPLETION_ROUTINE): Integer;
stdcall;
function WSASendDisconnect(s: TSocket;
lpOutboundDisconnectData: LPWSABUF):
Integer;
stdcall;
function WSASendTo(s: TSocket;
lpBuffers: LPWSABUF;
dwBufferCount: DWORD;
var
lpNumberOfBytesSent: DWORD;
dwFlags: DWORD;
lpTo: PSockAddr;
iTolen: Integer;
lpOverlapped: LPWSAOVERLAPPED;
lpCompletionRoutine: LPWSAOVERLAPPED_COMPLETION_ROUTINE): Integer;
stdcall;
function WSASetEvent(hEvent: WSAEVENT): WordBool;
stdcall;
function WSASocketA(af, iType, protocol: Integer;
lpProtocolInfo:
LPWSAProtocol_InfoA;
g: GROUP;
dwFlags: DWORD): TSocket;
stdcall;
function WSASocketW(af, iType, protocol: Integer;
lpProtocolInfo:
LPWSAProtocol_InfoW;
g: GROUP;
dwFlags: DWORD): TSocket;
stdcall;
function WSASocket(af, iType, protocol: Integer;
lpProtocolInfo:
LPWSAProtocol_Info;
g: GROUP;
dwFlags: DWORD): TSocket;
stdcall;
function WSAWaitForMultipleEvents(cEvents: DWORD;
lphEvents: PWSAEVENT;
fWaitAll: LongBool;
dwTimeout: DWORD;
fAlertable: LongBool): DWORD;
stdcall;
function WSAAddressToStringA(lpsaAddress: PSockAddr;
const dwAddressLength:
DWORD;
const lpProtocolInfo: LPWSAProtocol_InfoA;
const lpszAddressString: PChar;
var lpdwAddressStringLength: DWORD): Integer;
stdcall;
function WSAAddressToStringW(lpsaAddress: PSockAddr;
const dwAddressLength:
DWORD;
const lpProtocolInfo: LPWSAProtocol_InfoW;
const lpszAddressString: PWideChar;
var lpdwAddressStringLength: DWORD):
Integer;
stdcall;
function WSAAddressToString(lpsaAddress: PSockAddr;
const dwAddressLength:
DWORD;
const lpProtocolInfo: LPWSAProtocol_Info;
const lpszAddressString: PMBChar;
var lpdwAddressStringLength: DWORD):
Integer;
stdcall;
function WSAStringToAddressA(const AddressString: PChar;
const AddressFamily:
Integer;
const lpProtocolInfo: LPWSAProtocol_InfoA;
var lpAddress: TSockAddr;
var lpAddressLength: Integer): Integer;
stdcall;
function WSAStringToAddressW(const AddressString: PWideChar;
const
AddressFamily: Integer;
const lpProtocolInfo: LPWSAProtocol_InfoA;
var lpAddress: TSockAddr;
var lpAddressLength: Integer): Integer;
stdcall;
function WSAStringToAddress(const AddressString: PMBChar;
const AddressFamily:
Integer;
const lpProtocolInfo: LPWSAProtocol_Info;
var lpAddress: TSockAddr;
var lpAddressLength: Integer): Integer;
stdcall;
{ Registration and Name Resolution API functions }
function WSALookupServicebegin
A(var qsRestrictions: TWSAQuerySetA;
const
dwControlFlags: DWORD;
var hLookup: THANDLE): Integer;
stdcall;
function WSALookupServicebegin
W(var qsRestrictions: TWSAQuerySetW;
const
dwControlFlags: DWORD;
var hLookup: THANDLE): Integer;
stdcall;
function WSALookupServicebegin
(var qsRestrictions: TWSAQuerySet;
const
dwControlFlags: DWORD;
var hLookup: THANDLE): Integer;
stdcall;
function WSALookupServiceNextA(const hLookup: THandle;
const dwControlFlags:
DWORD;
var dwBufferLength: DWORD;
lpqsResults: PWSAQuerySetA): Integer;
stdcall;
function WSALookupServiceNextW(const hLookup: THandle;
const dwControlFlags:
DWORD;
var dwBufferLength: DWORD;
lpqsResults: PWSAQuerySetW): Integer;
stdcall;
function WSALookupServiceNext(const hLookup: THandle;
const dwControlFlags:
DWORD;
var dwBufferLength: DWORD;
lpqsResults: PWSAQuerySet): Integer;
stdcall;
function WSALookupServiceEnd(const hLookup: THandle): Integer;
stdcall;
function WSAInstallServiceClassA(const lpServiceClassInfo:
LPWSAServiceClassInfoA): Integer;
stdcall;
function WSAInstallServiceClassW(const lpServiceClassInfo:
LPWSAServiceClassInfoW): Integer;
stdcall;
function WSAInstallServiceClass(const lpServiceClassInfo:
LPWSAServiceClassInfo): Integer;
stdcall;
function WSARemoveServiceClass(const lpServiceClassId: PGUID): Integer;
stdcall;
function WSAGetServiceClassInfoA(const lpProviderId: PGUID;
const
lpServiceClassId: PGUID;
var lpdwBufSize: DWORD;
lpServiceClassInfo: LPWSAServiceClassInfoA): Integer;
stdcall;
function WSAGetServiceClassInfoW(const lpProviderId: PGUID;
const
lpServiceClassId: PGUID;
var lpdwBufSize: DWORD;
lpServiceClassInfo: LPWSAServiceClassInfoW): Integer;
stdcall;
function WSAGetServiceClassInfo(const lpProviderId: PGUID;
const
lpServiceClassId: PGUID;
var lpdwBufSize: DWORD;
lpServiceClassInfo: LPWSAServiceClassInfo): Integer;
stdcall;
function WSAEnumNameSpaceProvidersA(var lpdwBufferLength: DWORD;
const
lpnspBuffer: LPWSANameSpace_InfoA): Integer;
stdcall;
function WSAEnumNameSpaceProvidersW(var lpdwBufferLength: DWORD;
const
lpnspBuffer: LPWSANameSpace_InfoW): Integer;
stdcall;
function WSAEnumNameSpaceProviders(var lpdwBufferLength: DWORD;
const
lpnspBuffer: LPWSANameSpace_Info): Integer;
stdcall;
function WSAGetServiceClassNameByClassIdA(const lpServiceClassId: PGUID;
lpszServiceClassName: PChar;
var lpdwBufferLength: DWORD): Integer;
stdcall;
function WSAGetServiceClassNameByClassIdW(const lpServiceClassId: PGUID;
lpszServiceClassName: PWideChar;
var lpdwBufferLength: DWORD): Integer;
stdcall;
function WSAGetServiceClassNameByClassId(const lpServiceClassId: PGUID;
lpszServiceClassName: PMBChar;
var lpdwBufferLength: DWORD): Integer;
stdcall;
function WSASetServiceA(const lpqsRegInfo: LPWSAQuerySetA;
const essoperation:
TWSAeSetServiceOp;
const dwControlFlags: DWORD): Integer;
stdcall;
function WSASetServiceW(const lpqsRegInfo: LPWSAQuerySetW;
const essoperation:
TWSAeSetServiceOp;
const dwControlFlags: DWORD): Integer;
stdcall;
function WSASetService(const lpqsRegInfo: LPWSAQuerySet;
const essoperation:
TWSAeSetServiceOp;
const dwControlFlags: DWORD): Integer;
stdcall;
function WSAProviderConfigChange(var lpNotificationHandle: THandle;
lpOverlapped: LPWSAOVERLAPPED;
lpCompletionRoutine:
LPWSAOVERLAPPED_COMPLETION_ROUTINE): Integer;
stdcall;
{ Macros }
function WSAMakeSyncReply(Buflen, Error: Word): Longint;
function WSAMakeSelectReply(Event, Error: Word): Longint;
function WSAGetAsyncBuflen(Param: Longint): Word;
function WSAGetAsyncError(Param: Longint): Word;
function WSAGetSelectEvent(Param: Longint): Word;
function WSAGetSelectError(Param: Longint): Word;
procedure FD_CLR(Socket: TSocket;
var FDSet: TFDSet);
function FD_ISSET(Socket: TSocket;
var FDSet: TFDSet): Boolean;
procedure FD_SET(Socket: TSocket;
var FDSet: TFDSet);
procedure FD_ZERO(var FDSet: TFDSet);
{$INCLUDE ws2tcpip.inc}
{$INCLUDE wsipx.inc}
{$INCLUDE wsnwlink.inc}
{$INCLUDE wsnetbs.inc}
//=============================================================
implementation
//=============================================================
function accept;
external WINSOCK2_DLL name 'accept';
function bind;
external WINSOCK2_DLL name 'bind';
function closesocket;
external WINSOCK2_DLL name 'closesocket';
function connect;
external WINSOCK2_DLL name 'connect';
function ioctlsocket;
external WINSOCK2_DLL name 'ioctlsocket';
function getpeername;
external WINSOCK2_DLL name 'getpeername';
function getsockname;
external WINSOCK2_DLL name 'getsockname';
function getsockopt;
external WINSOCK2_DLL name 'getsockopt';
function htonl;
external WINSOCK2_DLL name 'htonl';
function htons;
external WINSOCK2_DLL name 'htons';
function inet_addr;
external WINSOCK2_DLL name 'inet_addr';
function inet_ntoa;
external WINSOCK2_DLL name 'inet_ntoa';
function listen;
external WINSOCK2_DLL name 'listen';
function ntohl;
external WINSOCK2_DLL name 'ntohl';
function ntohs;
external WINSOCK2_DLL name 'ntohs';
function recv;
external WINSOCK2_DLL name 'recv';
function recvfrom;
external WINSOCK2_DLL name 'recvfrom';
function select;
external WINSOCK2_DLL name 'select';
function send;
external WINSOCK2_DLL name 'send';
function sendto;
external WINSOCK2_DLL name 'sendto';
function setsockopt;
external WINSOCK2_DLL name 'setsockopt';
function shutdown;
external WINSOCK2_DLL name 'shutdown';
function socket;
external WINSOCK2_DLL name 'socket';
function gethostbyaddr;
external WINSOCK2_DLL name 'gethostbyaddr';
function gethostbyname;
external WINSOCK2_DLL name 'gethostbyname';
function gethostname;
external WINSOCK2_DLL name 'gethostname';
function getservbyport;
external WINSOCK2_DLL name 'getservbyport';
function getservbyname;
external WINSOCK2_DLL name 'getservbyname';
function getprotobynumber;
external WINSOCK2_DLL name 'getprotobynumber';
function getprotobyname;
external WINSOCK2_DLL name 'getprotobyname';
function WSAStartup;
external WINSOCK2_DLL name 'WSAStartup';
function WSACleanup;
external WINSOCK2_DLL name 'WSACleanup';
procedure WSASetLastError;
external WINSOCK2_DLL name 'WSASetLastError';
function WSAGetLastError;
external WINSOCK2_DLL name 'WSAGetLastError';
function WSAIsBlocking;
external WINSOCK2_DLL name 'WSAIsBlocking';
function WSAUnhookBlockingHook;
external WINSOCK2_DLL name
'WSAUnhookBlockingHook';
function WSASetBlockingHook;
external WINSOCK2_DLL name 'WSASetBlockingHook';
function WSACancelBlockingCall;
external WINSOCK2_DLL name
'WSACancelBlockingCall';
function WSAAsyncGetServByName;
external WINSOCK2_DLL name
'WSAAsyncGetServByName';
function WSAAsyncGetServByPort;
external WINSOCK2_DLL name
'WSAAsyncGetServByPort';
function WSAAsyncGetProtoByName;
external WINSOCK2_DLL name
'WSAAsyncGetProtoByName';
function WSAAsyncGetProtoByNumber;
external WINSOCK2_DLL name
'WSAAsyncGetProtoByNumber';
function WSAAsyncGetHostByName;
external WINSOCK2_DLL name
'WSAAsyncGetHostByName';
function WSAAsyncGetHostByAddr;
external WINSOCK2_DLL name
'WSAAsyncGetHostByAddr';
function WSACancelAsyncRequest;
external WINSOCK2_DLL name
'WSACancelAsyncRequest';
function WSAAsyncSelect;
external WINSOCK2_DLL name 'WSAAsyncSelect';
function __WSAFDIsSet;
external WINSOCK2_DLL name '__WSAFDIsSet';
{ WinSock 2 API new function prototypes }
function WSAAccept;
external WINSOCK2_DLL name 'WSAAccept';
function WSACloseEvent;
external WINSOCK2_DLL name 'WSACloseEvent';
function WSAConnect;
external WINSOCK2_DLL name 'WSAConnect';
function WSACreateEvent;
external WINSOCK2_DLL name 'WSACreateEvent';
function WSADuplicateSocketA;
external WINSOCK2_DLL name 'WSADuplicateSocketA';
function WSADuplicateSocketW;
external WINSOCK2_DLL name 'WSADuplicateSocketW';
function WSAEnumNetworkEvents;
external WINSOCK2_DLL name
'WSAEnumNetworkEvents';
function WSAEnumProtocolsA;
external WINSOCK2_DLL name 'WSAEnumProtocolsA';
function WSAEnumProtocolsW;
external WINSOCK2_DLL name 'WSAEnumProtocolsW';
function WSAEventSelect;
external WINSOCK2_DLL name 'WSAEventSelect';
function WSAGetOverlappedResult;
external WINSOCK2_DLL name
'WSAGetOverlappedResult';
function WSAGetQosByName;
external WINSOCK2_DLL name 'WSAGetQosByName';
function WSAhtonl;
external WINSOCK2_DLL name 'WSAhtonl';
function WSAhtons;
external WINSOCK2_DLL name 'WSAhtons';
function WSAIoctl;
external WINSOCK2_DLL name 'WSAIoctl';
function WSAJoinLeaf;
external WINSOCK2_DLL name 'WSAJoinLeaf';
function WSANtohl;
external WINSOCK2_DLL name 'WSANtohl';
function WSANtohs;
external WINSOCK2_DLL name 'WSANtohs';
function WSARecv;
external WINSOCK2_DLL name 'WSARecv';
function WSARecvDisconnect;
external WINSOCK2_DLL name 'WSARecvDisconnect';
function WSARecvFrom;
external WINSOCK2_DLL name 'WSARecvFrom';
function WSAResetEvent;
external WINSOCK2_DLL name 'WSAResetEvent';
function WSASend;
external WINSOCK2_DLL name 'WSASend';
function WSASendDisconnect;
external WINSOCK2_DLL name 'WSASendDisconnect';
function WSASendTo;
external WINSOCK2_DLL name 'WSASendTo';
function WSASetEvent;
external WINSOCK2_DLL name 'WSASetEvent';
function WSASocketA;
external WINSOCK2_DLL name 'WSASocketA';
function WSASocketW;
external WINSOCK2_DLL name 'WSASocketW';
function WSAWaitForMultipleEvents;
external WINSOCK2_DLL name
'WSAWaitForMultipleEvents';
function WSAAddressToStringA;
external WINSOCK2_DLL name 'WSAAddressToStringA';
function WSAAddressToStringW;
external WINSOCK2_DLL name 'WSAAddressToStringW';
function WSAStringToAddressA;
external WINSOCK2_DLL name 'WSAStringToAddressA';
function WSAStringToAddressW;
external WINSOCK2_DLL name 'WSAStringToAddressW';
{ Registration and Name Resolution API functions }
function WSALookupServicebegin
A;
external WINSOCK2_DLL name
'WSALookupServicebegin
A';
function WSALookupServicebegin
W;
external WINSOCK2_DLL name
'WSALookupServicebegin
W';
function WSALookupServiceNextA;
external WINSOCK2_DLL name
'WSALookupServiceNextA';
function WSALookupServiceNextW;
external WINSOCK2_DLL name
'WSALookupServiceNextW';
function WSALookupServiceend;
external WINSOCK2_DLL name 'WSALookupServiceEnd';
function WSAInstallServiceClassA;
external WINSOCK2_DLL name
'WSAInstallServiceClassA';
function WSAInstallServiceClassW;
external WINSOCK2_DLL name
'WSAInstallServiceClassW';
function WSARemoveServiceClass;
external WINSOCK2_DLL name
'WSARemoveServiceClass';
function WSAGetServiceClassInfoA;
external WINSOCK2_DLL name
'WSAGetServiceClassInfoA';
function WSAGetServiceClassInfoW;
external WINSOCK2_DLL name
'WSAGetServiceClassInfoW';
function WSAEnumNameSpaceProvidersA;
external WINSOCK2_DLL name
'WSAEnumNameSpaceProvidersA';
function WSAEnumNameSpaceProvidersW;
external WINSOCK2_DLL name
'WSAEnumNameSpaceProvidersW';
function WSAGetServiceClassNameByClassIdA;
external WINSOCK2_DLL name
'WSAGetServiceClassNameByClassIdA';
function WSAGetServiceClassNameByClassIdW;
external WINSOCK2_DLL name
'WSAGetServiceClassNameByClassIdW';
function WSASetServiceA;
external WINSOCK2_DLL name 'WSASetServiceA';
function WSASetServiceW;
external WINSOCK2_DLL name 'WSASetServiceW';
{$IFDEF UNICODE}
function WSADuplicateSocket;
external WINSOCK2_DLL name 'WSADuplicateSocketW';
function WSAEnumProtocols;
external WINSOCK2_DLL name 'WSAEnumProtocolsW';
function WSASocket;
external WINSOCK2_DLL name 'WSASocketW';
function WSAAddressToString;
external WINSOCK2_DLL name 'WSAAddressToStringW';
function WSAStringToAddress;
external WINSOCK2_DLL name 'WSAStringToAddressW';
function WSALookupServicebegin
;
external WINSOCK2_DLL name
'WSALookupServicebegin
W';
function WSALookupServiceNext;
external WINSOCK2_DLL name
'WSALookupServiceNextW';
function WSAInstallServiceClass;
external WINSOCK2_DLL name
'WSAInstallServiceClassW';
function WSAGetServiceClassInfo;
external WINSOCK2_DLL name
'WSAGetServiceClassInfoW';
function WSAEnumNameSpaceProviders;
external WINSOCK2_DLL name
'WSAEnumNameSpaceProvidersW';
function WSAGetServiceClassNameByClassId;
external WINSOCK2_DLL name
'WSAGetServiceClassNameByClassIdW';
function WSASetService;
external WINSOCK2_DLL name 'WSASetServiceW';
{$else
}
function WSADuplicateSocket;
external WINSOCK2_DLL name 'WSADuplicateSocketA';
function WSAEnumProtocols;
external WINSOCK2_DLL name 'WSAEnumProtocolsA';
function WSASocket;
external WINSOCK2_DLL name 'WSASocketA';
function WSAAddressToString;
external WINSOCK2_DLL name 'WSAAddressToStringA';
function WSAStringToAddress;
external WINSOCK2_DLL name 'WSAStringToAddressA';
function WSALookupServicebegin
;
external WINSOCK2_DLL name
'WSALookupServicebegin
A';
function WSALookupServiceNext;
external WINSOCK2_DLL name
'WSALookupServiceNextA';
function WSAInstallServiceClass;
external WINSOCK2_DLL name
'WSAInstallServiceClassA';
function WSAGetServiceClassInfo;
external WINSOCK2_DLL name
'WSAGetServiceClassInfoA';
function WSAEnumNameSpaceProviders;
external WINSOCK2_DLL name
'WSAEnumNameSpaceProvidersA';
function WSAGetServiceClassNameByClassId;
external WINSOCK2_DLL name
'WSAGetServiceClassNameByClassIdA';
function WSASetService;
external WINSOCK2_DLL name 'WSASetServiceA';
{$ENDIF}
function WSAProviderConfigChange;
external WINSOCK2_DLL name
'WSAProviderConfigChange';
function WSAMakeSyncReply;
begin
WSAMakeSyncReply := MakeLong(Buflen, Error);
end;

function WSAMakeSelectReply;
begin
WSAMakeSelectReply := MakeLong(Event, Error);
end;

function WSAGetAsyncBuflen;
begin
WSAGetAsyncBuflen := LOWORD(Param);
end;

function WSAGetAsyncError;
begin
WSAGetAsyncError := HIWORD(Param);
end;

function WSAGetSelectEvent;
begin
WSAGetSelectEvent := LOWORD(Param);
end;

function WSAGetSelectError;
begin
WSAGetSelectError := HIWORD(Param);
end;

procedure FD_CLR(Socket: TSocket;
var FDSet: TFDSet);
var
i: DWORD;
begin
i := 0;
while i < FDSet.fd_count do
begin
if FDSet.fd_array = Socket then
begin
while i < FDSet.fd_count - 1 do
begin
FDSet.fd_array := FDSet.fd_array[i + 1];
Inc(i);
end;
Dec(FDSet.fd_count);
Break;
end;
Inc(i);
end;
end;

function FD_ISSET(Socket: TSocket;
var FDSet: TFDSet): Boolean;
begin
Result := __WSAFDIsSet(Socket, FDSet);
end;

procedure FD_SET(Socket: TSocket;
var FDSet: TFDSet);
begin
if FDSet.fd_count < FD_SETSIZE then
begin
FDSet.fd_array[FDSet.fd_count] := Socket;
Inc(FDSet.fd_count);
end;
end;

procedure FD_ZERO(var FDSet: TFDSet);
begin
FDSet.fd_count := 0;
end;

// A macro convenient for setting up NETBIOS SOCKADDRs.
procedure SET_NETBIOS_SOCKADDR(snb: PSOCKADDR_NB;
const SnbType: Word;
const
Name: PChar;
const Port: Char);
var
len: Integer;
begin
if snb <> nil then
with snb^ do
begin
snb_family := AF_NETBIOS;
snb_type := SnbType;
len := StrLen(Name);
if len >= NETBIOS_NAME_LENGTH - 1 then
System.Move(Name^, snb_name, NETBIOS_NAME_LENGTH - 1)
else
begin
if len > 0 then
System.Move(Name^, snb_name, len);
FillChar((PChar(@snb_name) + len)^, NETBIOS_NAME_LENGTH - 1 - len, ' ');
end;
snb_name[NETBIOS_NAME_LENGTH - 1] := Port;
end;
end;

end.
 
Unit janFX;

{ original release 2-july-2000
janFX is written by Jan Verhoeven
most routines are written by myself,
some are extracted from freeware sources on the internet
to use this library add it to your library path
with Tools - Environment Options - Library path
in your application you just call the routines
for clarity and convenience you might preceed them with janFX like:
janFX.Buttonize(src,depth,weight);

this library is the updated succesor of my TjanPaintFX component
}

Interface
{$DEFINE USE_SCANLINE}
Uses
Windows, SysUtils, Classes, Graphics, math;
Type
// Type of a filter for use with Stretch()
TFilterProc = Function(Value: Single): Single;
TLightBrush = (lbBrightness, lbContrast, lbSaturation,
lbfisheye, lbrotate, lbtwist, lbrimple,
mbHor, mbTop, mbBottom, mbDiamond, mbWaste, mbRound,
mbround2, mbsplitround, mbsplitwaste);
// For scanline simplification
TRGBArray = Array[0..32767] Of TRGBTriple;
pRGBArray = ^TRGBArray;
Function ConvertColor(Value: Integer): TColor;
Function Set255(Clr: integer): integer;
Procedure CopyMe(tobmp: TBitmap;
frbmp: TGraphic);
Procedure MaskOval(src: TBitmap;
acolor: TColor);
Procedure Buttonize(src: TBitmap;
depth: byte;
weight: integer);
Procedure ButtonizeOval(src: TBitmap;
depth: byte;
weight: integer;
rim: String);
Procedure Seamless(src: TBitmap;
depth: byte);
Procedure ConvolveM(ray: Array Of integer;
z: word;
aBmp: TBitmap);
Procedure ConvolveE(ray: Array Of integer;
z: word;
aBmp: TBitmap);
Procedure ConvolveI(ray: Array Of integer;
z: word;
aBmp: TBitmap);
Procedure ConvolveFilter(filternr, edgenr: integer;
src: TBitmap);
// filternr=0..8 edgenr=0..2 (0 for seamless)
Procedure Solorize(src, dst: tbitmap;
amount: integer);
Procedure Posterize(src, dst: tbitmap;
amount: integer);
Procedure Blend(src1, src2, dst: tbitmap;
amount: extended);
Procedure ExtractColor(src: TBitmap;
Acolor: tcolor);
Procedure ExcludeColor(src: TBitmap;
Acolor: tcolor);
Procedure turn(src, dst: tbitmap);
Procedure turnRight(src, dst: Tbitmap);
Procedure HeightMap(src: Tbitmap;
amount: integer);
Procedure TexturizeTile(src: TBitmap;
amount: integer);
Procedure TexturizeOverlap(src: TBitmap;
amount: integer);
Procedure RippleRandom(src: TBitmap;
amount: integer);
Procedure RippleTooth(src: TBitmap;
amount: integer);
Procedure RippleTriangle(src: TBitmap;
amount: integer);
Procedure Triangles(src: TBitmap;
amount: integer);
Procedure DrawMandelJulia(src: Tbitmap;
x0, y0, x1, y1: extended;
Niter: integer;
Mandel: Boolean);
Procedure filterxblue(src: tbitmap;
min, max: integer);
Procedure filterxgreen(src: tbitmap;
min, max: integer);
Procedure filterxred(src: tbitmap;
min, max: integer);
Procedure filterblue(src: tbitmap;
min, max: integer);
Procedure filtergreen(src: tbitmap;
min, max: integer);
Procedure filterred(src: tbitmap;
min, max: integer);
Procedure Emboss(Var Bmp: TBitmap);
Procedure Plasma(src1, src2, dst: Tbitmap;
scale, turbulence: extended);
Procedure Shake(src, dst: Tbitmap;
factor: extended);
Procedure ShakeDown(src, dst: Tbitmap;
factor: extended);
Procedure KeepBlue(src: Tbitmap;
factor: extended);
Procedure KeepGreen(src: Tbitmap;
factor: extended);
Procedure KeepRed(src: Tbitmap;
factor: extended);
Procedure MandelBrot(src: Tbitmap;
factor: integer);
Procedure MaskMandelBrot(src: Tbitmap;
factor: integer);
Procedure FoldRight(src1, src2, dst: Tbitmap;
amount: extended);
Procedure QuartoOpaque(src, dst: tbitmap);
Procedure semiOpaque(src, dst: Tbitmap);
Procedure ShadowDownLeft(src: tbitmap);
Procedure ShadowDownRight(src: tbitmap);
Procedure shadowupleft(src: Tbitmap);
Procedure shadowupright(src: tbitmap);
Procedure Darkness(Var src: tbitmap;
Amount: integer);
Procedure Trace(src: Tbitmap;
intensity: integer);
Procedure FlipRight(src: Tbitmap);
Procedure FlipDown(src: Tbitmap);
Procedure SpotLight(Var src: Tbitmap;
Amount: integer;
Spot: TRect);
Procedure splitlight(Var clip: tbitmap;
amount: integer);
Procedure MakeSeamlessClip(Var clip: tbitmap;
seam: integer);
Procedure Wave(Var clip: tbitmap;
amount, inference, style: integer);
Procedure Mosaic(Var Bm: TBitmap;
size: Integer);
Function TrimInt(i, Min, Max: Integer): Integer;
Procedure SmoothRotate(Var Src, Dst: TBitmap;
cx, cy: Integer;
Angle: Extended);
Procedure SmoothResize(Var Src, Dst: TBitmap);
Procedure Twist(Bmp, Dst: TBitmap;
Amount: integer);
Procedure SplitBlur(Var clip: tbitmap;
Amount: integer);
Procedure SoftnessBlur(clip: tbitmap;
Amount: Integer);
Procedure GaussianBlur(Var clip: tbitmap;
Amount: integer);
Procedure Smooth(Var clip: tbitmap;
Weight: Integer);
Procedure GrayScale(Var clip: tbitmap);
Procedure AddColorNoise(Var clip: tbitmap;
Amount: Integer);
Procedure AddMonoNoise(Var clip: tbitmap;
Amount: Integer);
Procedure Contrast(Var clip: tbitmap;
Amount: Integer);
Procedure Lightness(Var clip: tbitmap;
Amount: Integer);
Procedure Saturation(Var clip: tbitmap;
Amount: Integer);
Procedure Spray(Var clip: tbitmap;
Amount: Integer);
Procedure AntiAlias(clip: tbitmap);
Procedure AntiAliasRect(clip: tbitmap;
XOrigin, YOrigin, XFinal, YFinal: Integer);
Procedure SmoothPoint(Var clip: tbitmap;
xk, yk: integer);
Procedure FishEye(Bmp, Dst: TBitmap;
Amount: Extended);
Procedure marble(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Procedure marble2(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Procedure marble3(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Procedure marble4(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Procedure marble5(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Procedure marble6(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Procedure marble7(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Procedure marble8(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Procedure squeezehor(src, dst: tbitmap;
amount: integer;
style: TLightBrush);
Procedure splitround(src, dst: tbitmap;
amount: integer;
style: TLightBrush);
Procedure tile(src, dst: TBitmap;
amount: integer);
// Interpolator
// Src: Source bitmap
// Dst: Destination bitmap
// filter: Weight calculation filter
// fwidth: Relative sample radius
Procedure Strecth(Src, Dst: TBitmap;
filter: TFilterProc;
fwidth: single);
Procedure Grow(Src1, Src2, Dst: TBitmap;
amount: extended;
x, y: integer);
Procedure Invert(src: tbitmap);
Procedure MirrorRight(src: Tbitmap);
Procedure MirrorDown(src: Tbitmap);
// Sample filters for use with Stretch()
Function SplineFilter(Value: Single): Single;
Function BellFilter(Value: Single): Single;
Function TriangleFilter(Value: Single): Single;
Function BoxFilter(Value: Single): Single;
Function HermiteFilter(Value: Single): Single;
Function Lanczos3Filter(Value: Single): Single;
Function MitchellFilter(Value: Single): Single;
Procedure Sharpen(SrcBmp: Tbitmap);
Const
MaxPixelCount = 32768;
// -----------------------------------------------------------------------------
//
// List of Filters
//
// -----------------------------------------------------------------------------
ResampleFilters: Array[0..6] Of Record
Name: String;
// Filter name
Filter: TFilterProc;
// Filter implementation
Width: Single;
// Suggested sampling width/radius
End = (
(Name: 'Box';
Filter: BoxFilter;
Width: 0.5),
(Name: 'Triangle';
Filter: TriangleFilter;
Width: 1.0),
(Name: 'Hermite';
Filter: HermiteFilter;
Width: 1.0),
(Name: 'Bell';
Filter: BellFilter;
Width: 1.5),
(Name: 'B-Spline';
Filter: SplineFilter;
Width: 2.0),
(Name: 'Lanczos3';
Filter: Lanczos3Filter;
Width: 3.0),
(Name: 'Mitchell';
Filter: MitchellFilter;
Width: 2.0)
);

Implementation


Type
TRGBTripleArray = Array[0..MaxPixelCount - 1] Of
TRGBTriple;
pRGBTripleArray = ^TRGBTripleArray;
TFColor = Record
b, g, r: Byte;
end;

//锐化
Procedure Sharpen(SrcBmp: Tbitmap);
//;AProgressBar:TProgressBar=Nil);
Function Min(a, b: integer): integer;
begin
If a < b then
result := a
else
result := b;
end;

Function Max(a, b: integer): integer;
begin
If a > b then
result := a
else
result := b;
end;
Var
i, j: integer;
SrcRow: pRGBArray;
SrcPreRow: pRGBArray;
Value: integer;
begin
// AProgressBar.Max:=SrcBmp.Height - 1;
For i := 1 To SrcBmp.Height - 1 do
begin
SrcRow := SrcBmp.ScanLine;
SrcPreRow := SrcBmp.ScanLine[i - 1];
//DestRow := DestBmp.ScanLine;
// for each pixel in row
For j := 0 To SrcBmp.Width - 1 do
begin
// add brightness value to pixel's RGB values
// RGB values must be less than 256
Value := SrcRow[j].rgbtRed + (SrcRow[j].rgbtRed - SrcPreRow[j - 1].rgbtRed) Div 2;
Value := Max(0, Value);
Value := Min(255, Value);
SrcRow[j].rgbtRed := value;
Value := SrcRow[j].rgbtGreen + (SrcRow[j].rgbtGreen - SrcPreRow[j - 1].rgbtGreen) Div 2;
Value := Max(0, Value);
Value := Min(255, Value);
SrcRow[j].rgbtGreen := value;
Value := SrcRow[j].rgbtBlue + (SrcRow[j].rgbtBlue - SrcPreRow[j - 1].rgbtBlue) Div 2;
Value := Max(0, Value);
Value := Min(255, Value);
SrcRow[j].rgbtBlue := value;
end;
// if AProgressBar<>Nil then
// AProgressBar.Position:=i;
end;
end;
// Bell filter
Function BellFilter(Value: Single): Single;
begin
If (Value < 0.0) then
Value := -Value;
If (Value < 0.5) then
Result := 0.75 - Sqr(Value)
else
If (Value < 1.5) then
begin
Value := Value - 1.5;
Result := 0.5 * Sqr(Value);
End else
Result := 0.0;
end;

// Box filter
// a.k.a. "Nearest Neighbour" filter
// anme: I have not been able to get acceptable
// results with this filter for subsampling.
Function BoxFilter(Value: Single): Single;
begin
If (Value > -0.5) And (Value <= 0.5) then
Result := 1.0
else
Result := 0.0;
end;

// Hermite filter
Function HermiteFilter(Value: Single): Single;
begin
// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1
If (Value < 0.0) then
Value := -Value;
If (Value < 1.0) then
Result := (2.0 * Value - 3.0) * Sqr(Value) + 1.0
else
Result := 0.0;
end;

// Lanczos3 filter
Function Lanczos3Filter(Value: Single): Single;
Function SinC(Value: Single): Single;
begin
If (Value <> 0.0) then
begin
Value := Value * Pi;
Result := sin(Value) / Value
End else
Result := 1.0;
end;
begin
If (Value < 0.0) then
Value := -Value;
If (Value < 3.0) then
Result := SinC(Value) * SinC(Value / 3.0)
else
Result := 0.0;
end;

Function MitchellFilter(Value: Single): Single;
Const
B = (1.0 / 3.0);
C = (1.0 / 3.0);
Var
tt: single;
begin
If (Value < 0.0) then
Value := -Value;
tt := Sqr(Value);
If (Value < 1.0) then
begin
Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * tt))
+ ((-18.0 + 12.0 * B + 6.0 * C) * tt)
+ (6.0 - 2 * B));
Result := Value / 6.0;
End else
If (Value < 2.0) then
begin
Value := (((-1.0 * B - 6.0 * C) * (Value * tt))
+ ((6.0 * B + 30.0 * C) * tt)
+ ((-12.0 * B - 48.0 * C) * Value)
+ (8.0 * B + 24 * C));
Result := Value / 6.0;
End else
Result := 0.0;
end;

// B-spline filter
Function SplineFilter(Value: Single): Single;
Var
tt: single;
begin
If (Value < 0.0) then
Value := -Value;
If (Value < 1.0) then
begin
tt := Sqr(Value);
Result := 0.5 * tt * Value - tt + 2.0 / 3.0;
End else
If (Value < 2.0) then
begin
Value := 2.0 - Value;
Result := 1.0 / 6.0 * Sqr(Value) * Value;
End else
Result := 0.0;
end;

// Triangle filter
// a.k.a. "Linear" or "Bilinear" filter
Function TriangleFilter(Value: Single): Single;
begin
If (Value < 0.0) then
Value := -Value;
If (Value < 1.0) then
Result := 1.0 - Value
else
Result := 0.0;
end;

Function IntToByte(i: Integer): Byte;
begin
If i > 255 then
Result := 255
else
If i < 0 then
Result := 0
else
Result := i;
end;

Procedure AddColorNoise(Var clip: tbitmap;
Amount: Integer);
Var
p0: pbytearray;
x, y, r, g, b: Integer;
begin
For y := 0 To clip.Height - 1 do
begin
p0 := clip.ScanLine[y];
For x := 0 To clip.Width - 1 do
begin
r := p0[x * 3] + (Random(Amount) - (Amount Shr 1));
g := p0[x * 3 + 1] + (Random(Amount) - (Amount Shr 1));
b := p0[x * 3 + 2] + (Random(Amount) - (Amount Shr 1));
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;

Procedure AddMonoNoise(Var clip: tbitmap;
Amount: Integer);
Var
p0: pbytearray;
x, y, a, r, g, b: Integer;
begin
For y := 0 To clip.Height - 1 do
begin
p0 := clip.scanline[y];
For x := 0 To clip.Width - 1 do
begin
a := Random(Amount) - (Amount Shr 1);
r := p0[x * 3] + a;
g := p0[x * 3 + 1] + a;
b := p0[x * 3 + 2] + a;
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;

Procedure SoftnessBlur(clip: tbitmap;
Amount: Integer);
Var
i: integer;
begin
For i := 1 To Amount do
AntiAlias(clip);
end;

Procedure AntiAlias(clip: tbitmap);
begin
AntiAliasRect(clip, 0, 0, clip.width, clip.height);
end;

Procedure AntiAliasRect(clip: tbitmap;
XOrigin, YOrigin,
XFinal, YFinal: Integer);
Var Memo, x, y: Integer;
(* Composantes primaires des points environnants *)
p0, p1, p2: pbytearray;
begin
If XFinal < XOrigin then
begin
Memo := XOrigin;
XOrigin := XFinal;
XFinal := Memo;
end;
(* Inversion des valeurs *)
If YFinal < YOrigin then
begin
Memo := YOrigin;
YOrigin := YFinal;
YFinal := Memo;
end;
(* si diff俽ence n俫ative*)
XOrigin := max(1, XOrigin);
YOrigin := max(1, YOrigin);
XFinal := min(clip.width - 2, XFinal);
YFinal := min(clip.height - 2, YFinal);
clip.PixelFormat := pf24bit;
For y := YOrigin To YFinal do
begin
p0 := clip.ScanLine[y - 1];
p1 := clip.scanline[y];
p2 := clip.ScanLine[y + 1];
For x := XOrigin To XFinal do
begin
p1[x * 3] := (p0[x * 3] + p2[x * 3] + p1[(x - 1) * 3] + p1[(x + 1) * 3]) Div 4;
p1[x * 3 + 1] := (p0[x * 3 + 1] + p2[x * 3 + 1] + p1[(x - 1) * 3 + 1] + p1[(x + 1) * 3 + 1]) Div 4;
p1[x * 3 + 2] := (p0[x * 3 + 2] + p2[x * 3 + 2] + p1[(x - 1) * 3 + 2] + p1[(x + 1) * 3 + 2]) Div 4;
end;
end;
end;

Procedure Contrast(Var clip: tbitmap;
Amount: Integer);
Var
p0: pbytearray;
rg, gg, bg, r, g, b, x, y: Integer;
begin
For y := 0 To clip.Height - 1 do
begin
p0 := clip.scanline[y];
For x := 0 To clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
rg := (Abs(127 - r) * Amount) Div 255;
gg := (Abs(127 - g) * Amount) Div 255;
bg := (Abs(127 - b) * Amount) Div 255;
If r > 127 then
r := r + rg else
r := r - rg;
If g > 127 then
g := g + gg else
g := g - gg;
If b > 127 then
b := b + bg else
b := b - bg;
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;

Procedure FishEye(Bmp, Dst: TBitmap;
Amount: Extended);
Var
xmid, ymid: Single;
fx, fy: Single;
r1, r2: Single;
ifx, ify: integer;
dx, dy: Single;
rmax: Single;
ty, tx: Integer;
weight_x, weight_y: Array[0..1] Of Single;
weight: Single;
new_red, new_green: Integer;
new_blue: Integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: Integer;
sli, slo: PByteArray;
begin
xmid := Bmp.Width / 2;
ymid := Bmp.Height / 2;
rmax := Dst.Width * Amount;
For ty := 0 To Dst.Height - 1 do
begin
For tx := 0 To Dst.Width - 1 do
begin
dx := tx - xmid;
dy := ty - ymid;
r1 := Sqrt(dx * dx + dy * dy);
If r1 = 0 then
begin
fx := xmid;
fy := ymid;
End
else
begin
r2 := rmax / 2 * (1 / (1 - r1 / rmax) - 1);
fx := dx * r2 / r1 + xmid;
fy := dy * r2 / r1 + ymid;
end;
ify := Trunc(fy);
ifx := Trunc(fx);
// Calculate the weights.
If fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
End else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
If fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
End else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;

If ifx < 0 then
ifx := Bmp.Width - 1 - (-ifx Mod Bmp.Width)
else
If ifx > Bmp.Width - 1 then
ifx := ifx Mod Bmp.Width;
If ify < 0 then
ify := Bmp.Height - 1 - (-ify Mod Bmp.Height)
else
If ify > Bmp.Height - 1 then
ify := ify Mod Bmp.Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
For ix := 0 To 1 do
begin
For iy := 0 To 1 do
begin
If ify + iy < Bmp.Height then
sli := Bmp.scanline[ify + iy]
else
sli := Bmp.scanline[Bmp.Height - ify - iy];
If ifx + ix < Bmp.Width then
begin
new_red := sli[(ifx + ix) * 3];
new_green := sli[(ifx + ix) * 3 + 1];
new_blue := sli[(ifx + ix) * 3 + 2];
End
else
begin
new_red := sli[(Bmp.Width - ifx - ix) * 3];
new_green := sli[(Bmp.Width - ifx - ix) * 3 + 1];
new_blue := sli[(Bmp.Width - ifx - ix) * 3 + 2];
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := Dst.scanline[ty];
slo[tx * 3] := Round(total_red);
slo[tx * 3 + 1] := Round(total_green);
slo[tx * 3 + 2] := Round(total_blue);
end;
end;
end;

Procedure GaussianBlur(Var clip: tbitmap;
Amount: integer);
Var
i: Integer;
begin
For i := Amount do
wnto 0 do
SplitBlur(clip, 3);
end;

Procedure Grayscale1(Var Bitmap: TBitmap);
Var
X: Integer;
Y: Integer;
PRGB: pRGBTriple;
Gray: Byte;
begin
For Y := 0 To (Bitmap.Height - 1) do
begin
PRGB := Bitmap.ScanLine[Y];
For X := 0 To (Bitmap.Width - 1) do
begin
// Gray := Trunc(0.3 * PRGB^.rgbtRed + 0.59 * PRGB^.rgbtGreen + 0.11 * PRGB^.rgbtBlue);
Gray := (77 * PRGB^.rgbtRed + 151 * PRGB^.rgbtGreen + 28 * PRGB^.rgbtBlue) Shr 8;
//Gray := (30 * Red + 59 * Green + 11 * Blue) div 100;

PRGB^.rgbtRed := Gray;
PRGB^.rgbtGreen := Gray;
PRGB^.rgbtBlue := Gray;
Inc(PRGB);
end;
end;
end;

Procedure GrayScale(Var clip: tbitmap);
Var
p0: pbytearray;
Gray, x, y: Integer;
begin
For y := 0 To clip.Height - 1 do
begin
p0 := clip.scanline[y];
For x := 0 To clip.Width - 1 do
begin
Gray := Round(p0[x * 3] * 0.3 + p0[x * 3 + 1] * 0.59 + p0[x * 3 + 2] * 0.11);
p0[x * 3] := Gray;
p0[x * 3 + 1] := Gray;
p0[x * 3 + 2] := Gray;
end;
end;
end;

Procedure Lightness(Var clip: tbitmap;
Amount: Integer);
Var
p0: pbytearray;
r, g, b, p, x, y: Integer;
begin
For y := 0 To clip.Height - 1 do
begin
p0 := clip.scanline[y];
For x := 0 To clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := IntToByte(r + ((255 - r) * Amount) Div 255);
p0[x * 3 + 1] := IntToByte(g + ((255 - g) * Amount) Div 255);
p0[x * 3 + 2] := IntToByte(b + ((255 - b) * Amount) Div 255);
end;
end;
end;

Procedure Darkness(Var src: tbitmap;
Amount: integer);
Var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
src.pixelformat := pf24bit;
For y := 0 To src.Height - 1 do
begin
p0 := src.scanline[y];
For x := 0 To src.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := IntToByte(r - ((r) * Amount) Div 255);
p0[x * 3 + 1] := IntToByte(g - ((g) * Amount) Div 255);
p0[x * 3 + 2] := IntToByte(b - ((b) * Amount) Div 255);
end;
end;
end;

Procedure marble(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Var x, xm, y, ym: integer;
xx, yy: extended;
p1, p2: pbytearray;
w, h: integer;
begin
h := src.height;
w := src.width;
dst.width := w;
dst.height := h;
dst.canvas.Draw(0, 0, src);
For y := 0 To h - 1 do
begin
yy := scale * cos((y Mod turbulence) / scale);
p1 := src.scanline[y];
For x := 0 To w - 1 do
begin
xx := -scale * sin((x Mod turbulence) / scale);
xm := round(abs(x + xx + yy));
ym := round(abs(y + yy + xx));
If ym < h then
begin
p2 := dst.scanline[ym];
If xm < w then
begin
p2[xm * 3] := p1[x * 3];
p2[xm * 3 + 1] := p1[x * 3 + 1];
p2[xm * 3 + 2] := p1[x * 3 + 2];
end;
end;
end;
end;
end;


Procedure marble2(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Var x, xm, y, ym: integer;
xx, yy: extended;
p1, p2: pbytearray;
w, h: integer;
begin
h := src.height;
w := src.width;
dst.assign(src);
For y := 0 To h - 1 do
begin
yy := scale * cos((y Mod turbulence) / scale);
p1 := src.scanline[y];
For x := 0 To w - 1 do
begin
xx := -scale * sin((x Mod turbulence) / scale);
xm := round(abs(x + xx - yy));
ym := round(abs(y + yy - xx));
If ym < h then
begin
p2 := dst.scanline[ym];
If xm < w then
begin
p2[xm * 3] := p1[x * 3];
p2[xm * 3 + 1] := p1[x * 3 + 1];
p2[xm * 3 + 2] := p1[x * 3 + 2];
end;
end;
end;
end;
end;

Procedure marble3(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Var x, xm, y, ym: integer;
xx, yy: extended;
p1, p2: pbytearray;
w, h: integer;
begin
h := src.height;
w := src.width;
dst.assign(src);
For y := 0 To h - 1 do
begin
yy := scale * cos((y Mod turbulence) / scale);
p1 := src.scanline[y];
For x := 0 To w - 1 do
begin
xx := -scale * sin((x Mod turbulence) / scale);
xm := round(abs(x - xx + yy));
ym := round(abs(y - yy + xx));
If ym < h then
begin
p2 := dst.scanline[ym];
If xm < w then
begin
p2[xm * 3] := p1[x * 3];
p2[xm * 3 + 1] := p1[x * 3 + 1];
p2[xm * 3 + 2] := p1[x * 3 + 2];
end;
end;
end;
end;
end;

Procedure marble4(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Var x, xm, y, ym: integer;
xx, yy: extended;
p1, p2: pbytearray;
w, h: integer;
begin
h := src.height;
w := src.width;
dst.assign(src);
For y := 0 To h - 1 do
begin
yy := scale * sin((y Mod turbulence) / scale);
p1 := src.scanline[y];
For x := 0 To w - 1 do
begin
xx := -scale * cos((x Mod turbulence) / scale);
xm := round(abs(x + xx + yy));
ym := round(abs(y + yy + xx));
If ym < h then
begin
p2 := dst.scanline[ym];
If xm < w then
begin
p2[xm * 3] := p1[x * 3];
p2[xm * 3 + 1] := p1[x * 3 + 1];
p2[xm * 3 + 2] := p1[x * 3 + 2];
end;
end;
end;
end;
end;

Procedure marble5(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Var x, xm, y, ym: integer;
xx, yy: extended;
p1, p2: pbytearray;
w, h: integer;
begin
h := src.height;
w := src.width;
dst.assign(src);
For y := h - 1 do
wnto 0 do
begin
yy := scale * cos((y Mod turbulence) / scale);
p1 := src.scanline[y];
For x := w - 1 do
wnto 0 do
begin
xx := -scale * sin((x Mod turbulence) / scale);
xm := round(abs(x + xx + yy));
ym := round(abs(y + yy + xx));
If ym < h then
begin
p2 := dst.scanline[ym];
If xm < w then
begin
p2[xm * 3] := p1[x * 3];
p2[xm * 3 + 1] := p1[x * 3 + 1];
p2[xm * 3 + 2] := p1[x * 3 + 2];
end;
end;
end;
end;
end;

Procedure marble6(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Var x, xm, y, ym: integer;
xx, yy: extended;
p1, p2: pbytearray;
w, h: integer;
begin
h := src.height;
w := src.width;
dst.assign(src);
For y := 0 To h - 1 do
begin
yy := scale * cos((y Mod turbulence) / scale);
p1 := src.scanline[y];
For x := 0 To w - 1 do
begin
xx := -tan((x Mod turbulence) / scale) / scale;
xm := round(abs(x + xx + yy));
ym := round(abs(y + yy + xx));
If ym < h then
begin
p2 := dst.scanline[ym];
If xm < w then
begin
p2[xm * 3] := p1[x * 3];
p2[xm * 3 + 1] := p1[x * 3 + 1];
p2[xm * 3 + 2] := p1[x * 3 + 2];
end;
end;
end;
end;
end;

Procedure marble7(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Var x, xm, y, ym: integer;
xx, yy: extended;
p1, p2: pbytearray;
w, h: integer;
begin
h := src.height;
w := src.width;
dst.assign(src);
For y := 0 To h - 1 do
begin
yy := scale * sin((y Mod turbulence) / scale);
p1 := src.scanline[y];
For x := 0 To w - 1 do
begin
xx := -tan((x Mod turbulence) / scale) / (scale * scale);
xm := round(abs(x + xx + yy));
ym := round(abs(y + yy + xx));
If ym < h then
begin
p2 := dst.scanline[ym];
If xm < w then
begin
p2[xm * 3] := p1[x * 3];
p2[xm * 3 + 1] := p1[x * 3 + 1];
p2[xm * 3 + 2] := p1[x * 3 + 2];
end;
end;
end;
end;
end;

Procedure marble8(Var src, dst: tbitmap;
scale: extended;
turbulence: integer);
Var x, xm, y, ym: integer;
xx, yy: extended;
p1, p2: pbytearray;
w, h: integer;
xs, xc, ax: extended;
begin
h := src.height;
w := src.width;
dst.assign(src);
For y := 0 To h - 1 do
begin
ax := (y Mod turbulence) / scale;
yy := scale * sin(ax) * cos(1.5 * ax);
p1 := src.scanline[y];
For x := 0 To w - 1 do
begin
ax := (x Mod turbulence) / scale;
xx := -scale * sin(2 * ax) * cos(ax);
xm := round(abs(x + xx + yy));
ym := round(abs(y + yy + xx));
If ym < h then
begin
p2 := dst.scanline[ym];
If xm < w then
begin
p2[xm * 3] := p1[x * 3];
p2[xm * 3 + 1] := p1[x * 3 + 1];
p2[xm * 3 + 2] := p1[x * 3 + 2];
end;
end;
end;
end;
end;

Procedure Saturation(Var clip: tbitmap;
Amount: Integer);
Var
p0: pbytearray;
Gray, r, g, b, x, y: Integer;
begin
For y := 0 To clip.Height - 1 do
begin
p0 := clip.scanline[y];
For x := 0 To clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
Gray := (r + g + b) Div 3;
p0[x * 3] := IntToByte(Gray + (((r - Gray) * Amount) Div 255));
p0[x * 3 + 1] := IntToByte(Gray + (((g - Gray) * Amount) Div 255));
p0[x * 3 + 2] := IntToByte(Gray + (((b - Gray) * Amount) Div 255));
end;
end;
end;

Procedure Smooth(Var clip: tbitmap;
Weight: Integer);
begin
//
end;

Procedure SmoothPoint(Var clip: tbitmap;
xk, yk: integer);
Var Bleu, Vert, Rouge, w, h: Integer;
color: TFColor;
Acolor: tcolor;
BB, GG, RR: Array[1..5] Of Integer;
begin
w := clip.width;
h := clip.height;
If (xk > 0) And (yk > 0) And (xk < w - 1) And (yk < h - 1) then
With clip.canvas do
begin
Acolor := colortorgb(pixels[xk, yk - 1]);
color.r := getrvalue(Acolor);
color.g := getgvalue(Acolor);
color.b := getbvalue(Acolor);
RR[1] := color.r;
GG[1] := color.g;
BB[1] := color.b;
Acolor := colortorgb(pixels[xk + 1, yk]);
color.r := getrvalue(Acolor);
color.g := getgvalue(Acolor);
color.b := getbvalue(Acolor);
RR[2] := color.r;
GG[2] := color.g;
BB[2] := color.b;
acolor := colortorgb(pixels[xk, yk + 1]);
color.r := getrvalue(Acolor);
color.g := getgvalue(Acolor);
color.b := getbvalue(Acolor);
RR[3] := color.r;
GG[3] := color.g;
BB[3] := color.b;
acolor := colortorgb(pixels[xk - 1, yk]);
color.r := getrvalue(Acolor);
color.g := getgvalue(Acolor);
color.b := getbvalue(Acolor);
RR[4] := color.r;
GG[4] := color.g;
BB[4] := color.b;
Bleu := (BB[1] + (BB[2] + BB[3] + BB[4])) Div 4;
(* Valeur moyenne *)
Vert := (GG[1] + (GG[2] + GG[3] + GG[4])) Div 4;
(* en cours d'倂aluation *)
Rouge := (RR[1] + (RR[2] + RR[3] + RR[4])) Div 4;
color.r := rouge;
color.g := vert;
color.b := bleu;
pixels[xk, yk] := rgb(color.r, color.g, color.b);
end;
end;

Procedure SmoothResize(Var Src, Dst: TBitmap);
Var
x, y, xP, yP,
yP2, xP2: Integer;
Read, Read2: PByteArray;
t, t3, t13, z, z2, iz2: Integer;
pc: PBytearray;
w1, w2, w3, w4: Integer;
Col1r, col1g, col1b, Col2r, col2g, col2b: byte;
begin
xP2 := ((src.Width - 1) Shl 15) Div Dst.Width;
yP2 := ((src.Height - 1) Shl 15) Div Dst.Height;
yP := 0;
For y := 0 To Dst.Height - 1 do
begin
xP := 0;
Read := src.ScanLine[yP Shr 15];
If yP Shr 16 < src.Height - 1 then
Read2 := src.ScanLine[yP Shr 15 + 1]
else
Read2 := src.ScanLine[yP Shr 15];
pc := Dst.scanline[y];
z2 := yP And $7FFF;
iz2 := $8000 - z2;
For x := 0 To Dst.Width - 1 do
begin
t := xP Shr 15;
t3 := t * 3;
t13 := t3 + 3;
Col1r := Read[t3];
Col1g := Read[t3 + 1];
Col1b := Read[t3 + 2];
Col2r := Read2[t3];
Col2g := Read2[t3 + 1];
Col2b := Read2[t3 + 2];
z := xP And $7FFF;
w2 := (z * iz2) Shr 15;
w1 := iz2 - w2;
w4 := (z * z2) Shr 15;
w3 := z2 - w4;
pc[x * 3 + 2] :=
(Col1b * w1 + Read[t13 + 2] * w2 +
Col2b * w3 + Read2[t13 + 2] * w4) Shr 15;
pc[x * 3 + 1] :=
(Col1g * w1 + Read[t13 + 1] * w2 +
Col2g * w3 + Read2[t13 + 1] * w4) Shr 15;
// (t+1)*3 is now t13
pc[x * 3] :=
(Col1r * w1 + Read2[t13] * w2 +
Col2r * w3 + Read2[t13] * w4) Shr 15;
Inc(xP, xP2);
end;
Inc(yP, yP2);
end;
end;

Procedure SmoothRotate(Var Src, Dst: TBitmap;
cx, cy: Integer;
Angle: Extended);
Type
TFColor = Record b, g, r: Byte end;
Var
Top,
Bottom,
Left,
Right,
eww, nsw,
fx, fy,
wx, wy: Extended;
cAngle,
sAngle: do
uble;
xDiff,
yDiff,
ifx, ify,
px, py,
ix, iy,
x, y: Integer;
nw, ne,
sw, se: TFColor;
P1, P2, P3: Pbytearray;
begin
Angle := angle;
Angle := -Angle * Pi / 180;
sAngle := Sin(Angle);
cAngle := Cos(Angle);
xDiff := (Dst.Width - Src.Width) Div 2;
yDiff := (Dst.Height - Src.Height) Div 2;
For y := 0 To Dst.Height - 1 do
begin
P3 := Dst.scanline[y];
py := 2 * (y - cy) + 1;
For x := 0 To Dst.Width - 1 do
begin
px := 2 * (x - cx) + 1;
fx := (((px * cAngle - py * sAngle) - 1) / 2 + cx) - xDiff;
fy := (((px * sAngle + py * cAngle) - 1) / 2 + cy) - yDiff;
ifx := Round(fx);
ify := Round(fy);
If (ifx > -1) And (ifx < Src.Width) And (ify > -1) And (ify < Src.Height) then
begin
eww := fx - ifx;
nsw := fy - ify;
iy := TrimInt(ify + 1, 0, Src.Height - 1);
ix := TrimInt(ifx + 1, 0, Src.Width - 1);
P1 := Src.scanline[ify];
P2 := Src.scanline[iy];
nw.r := P1[ifx * 3];
nw.g := P1[ifx * 3 + 1];
nw.b := P1[ifx * 3 + 2];
ne.r := P1[ix * 3];
ne.g := P1[ix * 3 + 1];
ne.b := P1[ix * 3 + 2];
sw.r := P2[ifx * 3];
sw.g := P2[ifx * 3 + 1];
sw.b := P2[ifx * 3 + 2];
se.r := P2[ix * 3];
se.g := P2[ix * 3 + 1];
se.b := P2[ix * 3 + 2];
Top := nw.b + eww * (ne.b - nw.b);
Bottom := sw.b + eww * (se.b - sw.b);
P3[x * 3 + 2] := IntToByte(Round(Top + nsw * (Bottom - Top)));
Top := nw.g + eww * (ne.g - nw.g);
Bottom := sw.g + eww * (se.g - sw.g);
P3[x * 3 + 1] := IntToByte(Round(Top + nsw * (Bottom - Top)));
Top := nw.r + eww * (ne.r - nw.r);
Bottom := sw.r + eww * (se.r - sw.r);
P3[x * 3] := IntToByte(Round(Top + nsw * (Bottom - Top)));
end;
end;
end;
end;

Procedure SplitBlur(Var clip: tbitmap;
Amount: integer);
Var
p0, p1, p2: pbytearray;
cx, i, x, y: Integer;
Buf: Array[0..3, 0..2] Of byte;
begin
If Amount = 0 then
Exit;
For y := 0 To clip.Height - 1 do
begin
p0 := clip.scanline[y];
If y - Amount < 0 then
p1 := clip.scanline[y]
else
{y-Amount>0} p1 := clip.ScanLine[y - Amount];
If y + Amount < clip.Height then
p2 := clip.ScanLine[y + Amount]
else
{y+Amount>=Height} p2 := clip.ScanLine[clip.Height - y];
For x := 0 To clip.Width - 1 do
begin
If x - Amount < 0 then
cx := x
else
{x-Amount>0} cx := x - Amount;
Buf[0, 0] := p1[cx * 3];
Buf[0, 1] := p1[cx * 3 + 1];
Buf[0, 2] := p1[cx * 3 + 2];
Buf[1, 0] := p2[cx * 3];
Buf[1, 1] := p2[cx * 3 + 1];
Buf[1, 2] := p2[cx * 3 + 2];
If x + Amount < clip.Width then
cx := x + Amount
else
{x+Amount>=Width} cx := clip.Width - x;
Buf[2, 0] := p1[cx * 3];
Buf[2, 1] := p1[cx * 3 + 1];
Buf[2, 2] := p1[cx * 3 + 2];
Buf[3, 0] := p2[cx * 3];
Buf[3, 1] := p2[cx * 3 + 1];
Buf[3, 2] := p2[cx * 3 + 2];
p0[x * 3] := (Buf[0, 0] + Buf[1, 0] + Buf[2, 0] + Buf[3, 0]) Shr 2;
p0[x * 3 + 1] := (Buf[0, 1] + Buf[1, 1] + Buf[2, 1] + Buf[3, 1]) Shr 2;
p0[x * 3 + 2] := (Buf[0, 2] + Buf[1, 2] + Buf[2, 2] + Buf[3, 2]) Shr 2;
end;
end;
end;

Procedure Spray(Var clip: tbitmap;
Amount: Integer);
Var
i, j, x, y, w, h, Val: Integer;
begin
h := clip.height;
w := clip.Width;
For i := 0 To w - 1 do
For j := 0 To h - 1 do
begin
Val := Random(Amount);
x := i + Val - Random(Val * 2);
y := j + Val - Random(Val * 2);
If (x > -1) And (x < w) And (y > -1) And (y < h) then
clip.canvas.Pixels[i, j] := clip.canvas.Pixels[x, y];
end;
end;

Procedure Mosaic(Var Bm: TBitmap;
size: Integer);
Var
x, y, i, j: integer;
p1, p2: pbytearray;
r, g, b: byte;
begin
y := 0;
Repeat
p1 := bm.scanline[y];
x := 0;
Repeat
j := 1;
Repeat
p2 := bm.scanline[y];
x := 0;
Repeat
r := p1[x * 3];
g := p1[x * 3 + 1];
b := p1[x * 3 + 2];
i := 1;
Repeat
p2[x * 3] := r;
p2[x * 3 + 1] := g;
p2[x * 3 + 2] := b;
inc(x);
inc(i);
Until (x >= bm.width) Or (i > size);
Until x >= bm.width;
inc(j);
inc(y);
Until (y >= bm.height) Or (j > size);
Until (y >= bm.height) Or (x >= bm.width);
Until y >= bm.height;
end;

Function TrimInt(i, Min, Max: Integer): Integer;
begin
If i > Max then
Result := Max
else
If i < Min then
Result := Min
else
Result := i;
end;

Procedure Twist(Bmp, Dst: TBitmap;
Amount: integer);
Var
fxmid, fymid: Single;
txmid, tymid: Single;
fx, fy: Single;
tx2, ty2: Single;
r: Single;
theta: Single;
ifx, ify: integer;
dx, dy: Single;
OFFSET: Single;
ty, tx: Integer;
weight_x, weight_y: Array[0..1] Of Single;
weight: Single;
new_red, new_green: Integer;
new_blue: Integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: Integer;
sli, slo: PBytearray;
Function ArcTan2(xt, yt: Single): Single;
begin
If xt = 0 then
If yt > 0 then
Result := Pi / 2
else
Result := -(Pi / 2)
else
begin
Result := ArcTan(yt / xt);
If xt < 0 then
Result := Pi + ArcTan(yt / xt);
end;
end;

begin
OFFSET := -(Pi / 2);
dx := Bmp.Width - 1;
dy := Bmp.Height - 1;
r := Sqrt(dx * dx + dy * dy);
tx2 := r;
ty2 := r;
txmid := (Bmp.Width - 1) / 2;
//Adjust these to move center of rotation
tymid := (Bmp.Height - 1) / 2;
//Adjust these to move ......
fxmid := (Bmp.Width - 1) / 2;
fymid := (Bmp.Height - 1) / 2;
If tx2 >= Bmp.Width then
tx2 := Bmp.Width - 1;
If ty2 >= Bmp.Height then
ty2 := Bmp.Height - 1;
For ty := 0 To Round(ty2) do
begin
For tx := 0 To Round(tx2) do
begin
dx := tx - txmid;
dy := ty - tymid;
r := Sqrt(dx * dx + dy * dy);
If r = 0 then
begin
fx := 0;
fy := 0;
End
else
begin
theta := ArcTan2(dx, dy) - r / Amount - OFFSET;
fx := r * Cos(theta);
fy := r * Sin(theta);
end;
fx := fx + fxmid;
fy := fy + fymid;
ify := Trunc(fy);
ifx := Trunc(fx);
// Calculate the weights.
If fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
End else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
If fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
End else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;

If ifx < 0 then
ifx := Bmp.Width - 1 - (-ifx Mod Bmp.Width)
else
If ifx > Bmp.Width - 1 then
ifx := ifx Mod Bmp.Width;
If ify < 0 then
ify := Bmp.Height - 1 - (-ify Mod Bmp.Height)
else
If ify > Bmp.Height - 1 then
ify := ify Mod Bmp.Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
For ix := 0 To 1 do
begin
For iy := 0 To 1 do
begin
If ify + iy < Bmp.Height then
sli := Bmp.scanline[ify + iy]
else
sli := Bmp.scanline[Bmp.Height - ify - iy];
If ifx + ix < Bmp.Width then
begin
new_red := sli[(ifx + ix) * 3];
new_green := sli[(ifx + ix) * 3 + 1];
new_blue := sli[(ifx + ix) * 3 + 2];
End
else
begin
new_red := sli[(Bmp.Width - ifx - ix) * 3];
new_green := sli[(Bmp.Width - ifx - ix) * 3 + 1];
new_blue := sli[(Bmp.Width - ifx - ix) * 3 + 2];
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := Dst.scanline[ty];
slo[tx * 3] := Round(total_red);
slo[tx * 3 + 1] := Round(total_green);
slo[tx * 3 + 2] := Round(total_blue);
end;
end;
end;

Procedure Wave(Var clip: tbitmap;
amount, inference, style: integer);
Var
c, c2, x, y: integer;
BitMap: TBitMap;
P1, P2: PByteArray;
b: integer;
fangle: real;
wavex: integer;
begin
BitMap := TBitMap.create;
Bitmap.assign(clip);
wavex := style;
fangle := pi / 2 / amount;
For y := BitMap.height - 1 - (2 * amount) do
wnto amount do
begin
P1 := BitMap.ScanLine[y];
b := 0;
For x := 0 To Bitmap.width - 1 do
begin
P2 := clip.scanline[y + amount + b];
P2[x * 3] := P1[x * 3];
P2[x * 3 + 1] := P1[x * 3 + 1];
P2[x * 3 + 2] := P1[x * 3 + 2];
Case wavex Of
0: b := amount * variant(sin(fangle * x));
1: b := amount * variant(sin(fangle * x) * cos(fangle * x));
2: b := amount * variant(sin(fangle * x) * sin(inference * fangle * x));
end;
end;
end;
BitMap.free;
end;

Procedure MakeSeamlessClip(Var clip: tbitmap;
seam: integer);
Var
p0, p1, p2: pbytearray;
h, w, i, j, sv, sh: integer;
f0, f1, f2: real;
begin
h := clip.height;
w := clip.width;
sv := h Div seam;
sh := w Div seam;
p1 := clip.scanline[0];
p2 := clip.ScanLine[h - 1];
For i := 0 To w - 1 do
begin
p1[i * 3] := p2[i * 3];
p1[i * 3 + 1] := p2[i * 3 + 1];
p1[i * 3 + 2] := p2[i * 3 + 2];
end;
p0 := clip.scanline[0];
p2 := clip.scanline[sv];
For j := 1 To sv - 1 do
begin
p1 := clip.scanline[j];
For i := 0 To w - 1 do
begin
f0 := (p2[i * 3] - p0[i * 3]) / sv * j + p0[i * 3];
p1[i * 3] := round(f0);
f1 := (p2[i * 3 + 1] - p0[i * 3 + 1]) / sv * j + p0[i * 3 + 1];
p1[i * 3 + 1] := round(f1);
f2 := (p2[i * 3 + 2] - p0[i * 3 + 2]) / sv * j + p0[i * 3 + 2];
p1[i * 3 + 2] := round(f2);
end;
end;
For j := 0 To h - 1 do
begin
p1 := clip.scanline[j];
p1[(w - 1) * 3] := p1[0];
p1[(w - 1) * 3 + 1] := p1[1];
p1[(w - 1) * 3 + 2] := p1[2];
For i := 1 To sh - 1 do
begin
f0 := (p1[(w - sh) * 3] - p1[(w - 1) * 3]) / sh * i + p1[(w - 1) * 3];
p1[(w - 1 - i) * 3] := round(f0);
f1 := (p1[(w - sh) * 3 + 1] - p1[(w - 1) * 3 + 1]) / sh * i + p1[(w - 1) * 3 + 1];
p1[(w - 1 - i) * 3 + 1] := round(f1);
f2 := (p1[(w - sh) * 3 + 2] - p1[(w - 1) * 3 + 2]) / sh * i + p1[(w - 1) * 3 + 2];
p1[(w - 1 - i) * 3 + 2] := round(f2);
end;
end;
end;

Procedure splitlight(Var clip: tbitmap;
amount: integer);
Var x, y, i: integer;
p1: pbytearray;
Function sinpixs(a: integer): integer;
begin
result := variant(sin(a / 255 * pi / 2) * 255);
end;
begin
For i := 1 To amount do
For y := 0 To clip.height - 1 do
begin
p1 := clip.scanline[y];
For x := 0 To clip.width - 1 do
begin
p1[x * 3] := sinpixs(p1[x * 3]);
p1[x * 3 + 1] := sinpixs(p1[x * 3 + 1]);
p1[x * 3 + 2] := sinpixs(p1[x * 3 + 2]);
end;
end;
end;

Procedure squeezehor(src, dst: tbitmap;
amount: integer;
style: TLightBrush);
Var dx, x, y, h, w, c, cx: integer;
R: trect;
bm: tbitmap;
p0, p1: pbytearray;
begin
If amount > (src.width Div 2) then
amount := src.width Div 2;
bm := tbitmap.create;
bm.PixelFormat := pf24bit;
bm.height := 1;
bm.width := src.width;
cx := src.width Div 2;
p0 := bm.scanline[0];
For y := 0 To src.height - 1 do
begin
p1 := src.scanline[y];
For x := 0 To src.width - 1 do
begin
c := x * 3;
p0[c] := p1[c];
p0[c + 1] := p1[c + 1];
p0[c + 2] := p1[c + 2];
end;
Case style Of
mbhor:
begin
dx := amount;
R := rect(dx, y, src.width - dx, y + 1);
end;
mbtop:
begin
dx := round((src.height - 1 - y) / src.height * amount);
R := rect(dx, y, src.width - dx, y + 1);
end;
mbBottom:
begin
dx := round(y / src.height * amount);
R := rect(dx, y, src.width - dx, y + 1);
end;
mbDiamond:
begin
dx := round(amount * abs(cos(y / (src.height - 1) * pi)));
R := rect(dx, y, src.width - dx, y + 1);
end;
mbWaste:
begin
dx := round(amount * abs(sin(y / (src.height - 1) * pi)));
R := rect(dx, y, src.width - dx, y + 1);
end;
mbRound:
begin
dx := round(amount * abs(sin(y / (src.height - 1) * pi)));
R := rect(cx - dx, y, cx + dx, y + 1);
end;
mbRound2:
begin
dx := round(amount * abs(sin(y / (src.height - 1) * pi * 2)));
R := rect(cx - dx, y, cx + dx, y + 1);
end;
end;
dst.Canvas.StretchDraw(R, bm);
end;
bm.free;
end;


Procedure tile(src, dst: TBitmap;
amount: integer);
Var w, h, w2, h2, i, j: integer;
bm: tbitmap;
begin
w := src.width;
h := src.height;
dst.width := w;
dst.height := h;
dst.Canvas.draw(0, 0, src);
If (amount <= 0) Or ((w Div amount) < 5) Or ((h Div amount) < 5) then
exit;
h2 := h Div amount;
w2 := w Div amount;
bm := tbitmap.create;
bm.width := w2;
bm.height := h2;
bm.PixelFormat := pf24bit;
smoothresize(src, bm);
For j := 0 To amount - 1 do
For i := 0 To amount - 1 do
dst.canvas.Draw(i * w2, j * h2, bm);
bm.free;
end;


// -----------------------------------------------------------------------------
//
// Interpolator
//
// -----------------------------------------------------------------------------
Type
// Contributor for a pixel
TContributor = Record
pixel: integer;
// Source pixel
weight: single;
// Pixel weight
end;

TContributorList = Array[0..0] Of TContributor;
PContributorList = ^TContributorList;
// List of source pixels contributing to a destination pixel
TCList = Record
n: integer;
p: PContributorList;
end;

TCListList = Array[0..0] Of TCList;
PCListList = ^TCListList;
TRGB = Packed Record
r, g, b: single;
end;

// Physical bitmap pixel
TColorRGB = Packed Record
r, g, b: BYTE;
end;
PColorRGB = ^TColorRGB;
// Physical bitmap scanline (row)
TRGBList = Packed Array[0..0] Of TColorRGB;
PRGBList = ^TRGBList;

Procedure Strecth(Src, Dst: TBitmap;
filter: TFilterProc;
fwidth: single);
Var
xscale, yscale: single;
// Zoom scale factors
i, j, k: integer;
// Loop variables
center: single;
// Filter calculation variables
width, fscale, weight: single;
// Filter calculation variables
left, right: integer;
// Filter calculation variables
n: integer;
// Pixel number
Work: TBitmap;
contrib: PCListList;
rgb: TRGB;
color: TColorRGB;
{$IFDEF USE_SCANLINE}
SourceLine,
DestLine: PRGBList;
SourcePixel,
DestPixel: PColorRGB;
Delta,
DestDelta: integer;
{$ENDIF}
SrcWidth,
SrcHeight,
DstWidth,
DstHeight: integer;
Function Color2RGB(Color: TColor): TColorRGB;
begin
Result.r := Color And $000000FF;
Result.g := (Color And $0000FF00) Shr 8;
Result.b := (Color And $00FF0000) Shr 16;
end;

Function RGB2Color(Color: TColorRGB): TColor;
begin
Result := Color.r Or (Color.g Shl 8) Or (Color.b Shl 16);
end;

begin
DstWidth := Dst.Width;
DstHeight := Dst.Height;
SrcWidth := Src.Width;
SrcHeight := Src.Height;
If (SrcWidth < 1) Or (SrcHeight < 1) then
Raise Exception.Create('Source bitmap too small');
// Create intermediate image to hold horizontal zoom
Work := TBitmap.Create;
Try
Work.Height := SrcHeight;
Work.Width := DstWidth;
// xscale := DstWidth / SrcWidth;
// yscale := DstHeight / SrcHeight;
// Improvement suggested by David Ullrich:
If (SrcWidth = 1) then
xscale := DstWidth / SrcWidth
else
xscale := (DstWidth - 1) / (SrcWidth - 1);
If (SrcHeight = 1) then
yscale := DstHeight / SrcHeight
else
yscale := (DstHeight - 1) / (SrcHeight - 1);
// This implementation only works on 24-bit images because it uses
// TBitmap.Scanline
{$IFDEF USE_SCANLINE}
Src.PixelFormat := pf24bit;
Dst.PixelFormat := Src.PixelFormat;
Work.PixelFormat := Src.PixelFormat;
{$ENDIF}
// --------------------------------------------
// Pre-calculate filter contributions for a row
// -----------------------------------------------
GetMem(contrib, DstWidth * sizeof(TCList));
// Horizontal sub-sampling
// Scales from bigger to smaller width
If (xscale < 1.0) then
begin
width := fwidth / xscale;
fscale := 1.0 / xscale;
For i := 0 To DstWidth - 1 do
begin
contrib^.n := 0;
GetMem(contrib^.p, trunc(width * 2.0 + 1) * sizeof(TContributor));
center := i / xscale;
// Original code:
// left := ceil(center - width);
// right := floor(center + width);
left := floor(center - width);
right := ceil(center + width);
For j := left To right do
begin
weight := filter((center - j) / fscale) / fscale;
If (weight = 0.0) then
continue;
If (j < 0) then
n := -j
else
If (j >= SrcWidth) then
n := SrcWidth - j + SrcWidth - 1
else
n := j;
k := contrib^.n;
contrib^.n := contrib^.n + 1;
contrib^.p^[k].pixel := n;
contrib^.p^[k].weight := weight;
end;
end;
End else
// Horizontal super-sampling
// Scales from smaller to bigger width
begin
For i := 0 To DstWidth - 1 do
begin
contrib^.n := 0;
GetMem(contrib^.p, trunc(fwidth * 2.0 + 1) * sizeof(TContributor));
center := i / xscale;
// Original code:
// left := ceil(center - fwidth);
// right := floor(center + fwidth);
left := floor(center - fwidth);
right := ceil(center + fwidth);
For j := left To right do
begin
weight := filter(center - j);
If (weight = 0.0) then
continue;
If (j < 0) then
n := -j
else
If (j >= SrcWidth) then
n := SrcWidth - j + SrcWidth - 1
else
n := j;
k := contrib^.n;
contrib^.n := contrib^.n + 1;
contrib^.p^[k].pixel := n;
contrib^.p^[k].weight := weight;
end;
end;
end;

// ----------------------------------------------------
// Apply filter to sample horizontally from Src to Work
// ----------------------------------------------------
For k := 0 To SrcHeight - 1 do
begin
{$IFDEF USE_SCANLINE}
SourceLine := Src.ScanLine[k];
DestPixel := Work.ScanLine[k];
{$ENDIF}
For i := 0 To DstWidth - 1 do
begin
rgb.r := 0.0;
rgb.g := 0.0;
rgb.b := 0.0;
For j := 0 To contrib^.n - 1 do
begin
{$IFDEF USE_SCANLINE}
color := SourceLine^[contrib^.p^[j].pixel];
{$else
}
color := Color2RGB(Src.Canvas.Pixels[contrib^.p^[j].pixel, k]);
{$ENDIF}
weight := contrib^.p^[j].weight;
If (weight = 0.0) then
continue;
rgb.r := rgb.r + color.r * weight;
rgb.g := rgb.g + color.g * weight;
rgb.b := rgb.b + color.b * weight;
end;
If (rgb.r > 255.0) then
color.r := 255
else
If (rgb.r < 0.0) then
color.r := 0
else
color.r := round(rgb.r);
If (rgb.g > 255.0) then
color.g := 255
else
If (rgb.g < 0.0) then
color.g := 0
else
color.g := round(rgb.g);
If (rgb.b > 255.0) then
color.b := 255
else
If (rgb.b < 0.0) then
color.b := 0
else
color.b := round(rgb.b);
{$IFDEF USE_SCANLINE}
// Set new pixel value
DestPixel^ := color;
// Move on to next column
inc(DestPixel);
{$else
}
Work.Canvas.Pixels[i, k] := RGB2Color(color);
{$ENDIF}
end;
end;

// Free the memory allocated for horizontal filter weights
For i := 0 To DstWidth - 1 do
FreeMem(contrib^.p);
FreeMem(contrib);
// -----------------------------------------------
// Pre-calculate filter contributions for a column
// -----------------------------------------------
GetMem(contrib, DstHeight * sizeof(TCList));
// Vertical sub-sampling
// Scales from bigger to smaller height
If (yscale < 1.0) then
begin
width := fwidth / yscale;
fscale := 1.0 / yscale;
For i := 0 To DstHeight - 1 do
begin
contrib^.n := 0;
GetMem(contrib^.p, trunc(width * 2.0 + 1) * sizeof(TContributor));
center := i / yscale;
// Original code:
// left := ceil(center - width);
// right := floor(center + width);
left := floor(center - width);
right := ceil(center + width);
For j := left To right do
begin
weight := filter((center - j) / fscale) / fscale;
If (weight = 0.0) then
continue;
If (j < 0) then
n := -j
else
If (j >= SrcHeight) then
n := SrcHeight - j + SrcHeight - 1
else
n := j;
k := contrib^.n;
contrib^.n := contrib^.n + 1;
contrib^.p^[k].pixel := n;
contrib^.p^[k].weight := weight;
end;
End
End else
// Vertical super-sampling
// Scales from smaller to bigger height
begin
For i := 0 To DstHeight - 1 do
begin
contrib^.n := 0;
GetMem(contrib^.p, trunc(fwidth * 2.0 + 1) * sizeof(TContributor));
center := i / yscale;
// Original code:
// left := ceil(center - fwidth);
// right := floor(center + fwidth);
left := floor(center - fwidth);
right := ceil(center + fwidth);
For j := left To right do
begin
weight := filter(center - j);
If (weight = 0.0) then
continue;
If (j < 0) then
n := -j
else
If (j >= SrcHeight) then
n := SrcHeight - j + SrcHeight - 1
else
n := j;
k := contrib^.n;
contrib^.n := contrib^.n + 1;
contrib^.p^[k].pixel := n;
contrib^.p^[k].weight := weight;
end;
end;
end;

// --------------------------------------------------
// Apply filter to sample vertically from Work to Dst
// --------------------------------------------------
{$IFDEF USE_SCANLINE}
SourceLine := Work.ScanLine[0];
Delta := integer(Work.ScanLine[1]) - integer(SourceLine);
DestLine := Dst.ScanLine[0];
DestDelta := integer(Dst.ScanLine[1]) - integer(DestLine);
{$ENDIF}
For k := 0 To DstWidth - 1 do
begin
{$IFDEF USE_SCANLINE}
DestPixel := pointer(DestLine);
{$ENDIF}
For i := 0 To DstHeight - 1 do
begin
rgb.r := 0;
rgb.g := 0;
rgb.b := 0;
// weight := 0.0;
For j := 0 To contrib^.n - 1 do
begin
{$IFDEF USE_SCANLINE}
color := PColorRGB(integer(SourceLine) + contrib^.p^[j].pixel * Delta)^;
{$else
}
color := Color2RGB(Work.Canvas.Pixels[k, contrib^.p^[j].pixel]);
{$ENDIF}
weight := contrib^.p^[j].weight;
If (weight = 0.0) then
continue;
rgb.r := rgb.r + color.r * weight;
rgb.g := rgb.g + color.g * weight;
rgb.b := rgb.b + color.b * weight;
end;
If (rgb.r > 255.0) then
color.r := 255
else
If (rgb.r < 0.0) then
color.r := 0
else
color.r := round(rgb.r);
If (rgb.g > 255.0) then
color.g := 255
else
If (rgb.g < 0.0) then
color.g := 0
else
color.g := round(rgb.g);
If (rgb.b > 255.0) then
color.b := 255
else
If (rgb.b < 0.0) then
color.b := 0
else
color.b := round(rgb.b);
{$IFDEF USE_SCANLINE}
DestPixel^ := color;
inc(integer(DestPixel), DestDelta);
{$else
}
Dst.Canvas.Pixels[k, i] := RGB2Color(color);
{$ENDIF}
end;
{$IFDEF USE_SCANLINE}
Inc(SourceLine, 1);
Inc(DestLine, 1);
{$ENDIF}
end;

// Free the memory allocated for vertical filter weights
For i := 0 To DstHeight - 1 do
FreeMem(contrib^.p);
FreeMem(contrib);
Finally
Work.Free;
end;
end;

Procedure Grow(Src1, Src2, Dst: TBitmap;
amount: extended;
x, y: integer);
Var
bm: tbitmap;
h, w, hr, wr: integer;
begin
w := src1.Width;
h := src1.Height;
Dst.Width := w;
Dst.Height := h;
Dst.Canvas.Draw(0, 0, Src1);
wr := round(amount * w);
hr := round(amount * h);
bm := tbitmap.create;
bm.width := wr;
bm.height := hr;
Strecth(Src2, bm, resamplefilters[4].filter, resamplefilters[4].width);
Dst.Canvas.Draw(x, y, bm);
bm.free;
end;

Procedure SpotLight(Var src: Tbitmap;
Amount: integer;
Spot: TRect);
Var bm: tbitmap;
w, h: integer;
begin
Darkness(src, amount);
w := src.Width;
h := src.Height;
bm := tbitmap.create;
bm.width := w;
bm.height := h;
bm.canvas.Brush.color := clblack;
bm.canvas.FillRect(rect(0, 0, w, h));
bm.canvas.brush.Color := clwhite;
bm.canvas.Ellipse(Spot.left, spot.top, spot.right, spot.bottom);
bm.transparent := true;
bm.TransparentColor := clwhite;
src.Canvas.Draw(0, 0, bm);
bm.free;
end;

Procedure FlipDown(src: Tbitmap);
Var
dest: tbitmap;
w, h, x, y: integer;
pd, ps: pbytearray;
begin
w := src.width;
h := src.height;
dest := tbitmap.create;
dest.width := w;
dest.height := h;
dest.pixelformat := pf24bit;
src.pixelformat := pf24bit;
For y := 0 To h - 1 do
begin
pd := dest.scanline[y];
ps := src.scanline[h - 1 - y];
For x := 0 To w - 1 do
begin
pd[x * 3] := ps[x * 3];
pd[x * 3 + 1] := ps[x * 3 + 1];
pd[x * 3 + 2] := ps[x * 3 + 2];
end;
end;
src.assign(dest);
dest.free;
end;

Procedure FlipRight(src: Tbitmap);
Var
dest: tbitmap;
w, h, x, y: integer;
pd, ps: pbytearray;
begin
w := src.width;
h := src.height;
dest := tbitmap.create;
dest.width := w;
dest.height := h;
dest.pixelformat := pf24bit;
src.pixelformat := pf24bit;
For y := 0 To h - 1 do
begin
pd := dest.scanline[y];
ps := src.scanline[y];
For x := 0 To w - 1 do
begin
pd[x * 3] := ps[(w - 1 - x) * 3];
pd[x * 3 + 1] := ps[(w - 1 - x) * 3 + 1];
pd[x * 3 + 2] := ps[(w - 1 - x) * 3 + 2];
end;
end;
src.assign(dest);
dest.free;
end;

Procedure Trace(src: Tbitmap;
intensity: integer);
Var
x, y, i: integer;
P1, P2, P3, P4: PByteArray;
tb, TraceB: byte;
hasb: boolean;
bitmap: tbitmap;
begin
bitmap := tbitmap.create;
bitmap.width := src.width;
bitmap.height := src.height;
bitmap.canvas.draw(0, 0, src);
bitmap.PixelFormat := pf8bit;
src.PixelFormat := pf24bit;
hasb := false;
TraceB := $00;
For i := 1 To Intensity do
begin
For y := 0 To BitMap.height - 2 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y + 1];
P3 := src.scanline[y];
P4 := src.scanline[y + 1];
x := 0;
Repeat
If p1[x] <> p1[x + 1] then
begin
If Not hasb then
begin
tb := p1[x + 1];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
End
else
begin
If p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
End
else
begin
p3[(x + 1) * 3] := TraceB;
p3[(x + 1) * 3 + 1] := TraceB;
p3[(x + 1) * 3 + 1] := TraceB;
end;
end;
end;
If p1[x] <> p2[x] then
begin
If Not hasb then
begin
tb := p2[x];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
End
else
begin
If p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
End
else
begin
p4[x * 3] := TraceB;
p4[x * 3 + 1] := TraceB;
p4[x * 3 + 2] := TraceB;
end;
end;
end;
inc(x);
Until x >= (BitMap.width - 2);
end;
// do
the same in the opposite direction
// only when intensity>1
If i > 1 then
For y := BitMap.height - 1 do
wnto 1 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y - 1];
P3 := src.scanline[y];
P4 := src.scanline[y - 1];
x := Bitmap.width - 1;
Repeat
If p1[x] <> p1[x - 1] then
begin
If Not hasb then
begin
tb := p1[x - 1];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
End
else
begin
If p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
End
else
begin
p3[(x - 1) * 3] := TraceB;
p3[(x - 1) * 3 + 1] := TraceB;
p3[(x - 1) * 3 + 2] := TraceB;
end;
end;
end;
If p1[x] <> p2[x] then
begin
If Not hasb then
begin
tb := p2[x];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
End
else
begin
If p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
End
else
begin
p4[x * 3] := TraceB;
p4[x * 3 + 1] := TraceB;
p4[x * 3 + 2] := TraceB;
end;
end;
end;
dec(x);
Until x <= 1;
end;
end;
bitmap.free;
end;

Procedure shadowupleft(src: Tbitmap);
Var
c, c2, x, y: integer;
BitMap: TBitMap;
P1, P2: PByteArray;
begin
BitMap := TBitMap.create;
bitmap.width := src.width;
bitmap.height := src.height;
Bitmap.pixelformat := pf24bit;
Bitmap.canvas.draw(0, 0, src);
For y := 0 To BitMap.height - 5 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y + 4];
For x := 0 To Bitmap.width - 5 do
If P1[x * 3] > P2[(x + 4) * 3] then
begin
P1[x * 3] := P2[(x + 4) * 3] + 1;
P1[x * 3 + 1] := P2[(x + 4) * 3 + 1] + 1;
P1[x * 3 + 2] := P2[(x + 4) * 3 + 2] + 1;
end;
end;
src.Assign(bitmap);
BitMap.free;
end;

Procedure shadowupright(src: tbitmap);
Var
x, y: integer;
BitMap: TBitMap;
P1, P2: PByteArray;
begin
BitMap := TBitMap.create;
bitmap.width := src.width;
bitmap.height := src.height;
Bitmap.pixelformat := pf24bit;
Bitmap.canvas.draw(0, 0, src);
For y := 0 To bitmap.height - 5 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y + 4];
For x := Bitmap.width - 1 do
wnto 4 do
If P1[x * 3] > P2[(x - 4) * 3] then
begin
P1[x * 3] := P2[(x - 4) * 3] + 1;
P1[x * 3 + 1] := P2[(x - 4) * 3 + 1] + 1;
P1[x * 3 + 2] := P2[(x - 4) * 3 + 2] + 1;
end;
end;
src.Assign(bitmap);
BitMap.free;
end;

Procedure ShadowDownLeft(src: tbitmap);
Var
x, y: integer;
BitMap: TBitMap;
P1, P2: PByteArray;
begin
BitMap := TBitMap.create;
bitmap.width := src.width;
bitmap.height := src.height;
Bitmap.pixelformat := pf24bit;
Bitmap.canvas.draw(0, 0, src);
For y := bitmap.height - 1 do
wnto 4 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y - 4];
For x := 0 To Bitmap.width - 5 do
If P1[x * 3] > P2[(x + 4) * 3] then
begin
P1[x * 3] := P2[(x + 4) * 3] + 1;
P1[x * 3 + 1] := P2[(x + 4) * 3 + 1] + 1;
P1[x * 3 + 2] := P2[(x + 4) * 3 + 2] + 1;
end;
end;
src.Assign(bitmap);
BitMap.free;
end;

Procedure ShadowDownRight(src: tbitmap);
Var
x, y: integer;
BitMap: TBitMap;
P1, P2: PByteArray;
begin
BitMap := TBitMap.create;
bitmap.width := src.width;
bitmap.height := src.height;
Bitmap.pixelformat := pf24bit;
Bitmap.canvas.draw(0, 0, src);
For y := bitmap.height - 1 do
wnto 4 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y - 4];
For x := Bitmap.width - 1 do
wnto 4 do
If P1[x * 3] > P2[(x - 4) * 3] then
begin
P1[x * 3] := P2[(x - 4) * 3] + 1;
P1[x * 3 + 1] := P2[(x - 4) * 3 + 1] + 1;
P1[x * 3 + 2] := P2[(x - 4) * 3 + 2] + 1;
end;
end;
src.Assign(bitmap);
BitMap.free;
end;

Procedure semiOpaque(src, dst: Tbitmap);
Var b: tbitmap;
P: Pbytearray;
x, y: integer;
begin
b := tbitmap.create;
b.width := src.width;
b.height := src.height;
b.PixelFormat := pf24bit;
b.canvas.draw(0, 0, src);
For y := 0 To b.height - 1 do
begin
p := b.scanline[y];
If (y Mod 2) = 0 then
begin
For x := 0 To b.width - 1 do
If (x Mod 2) = 0 then
begin
p[x * 3] := $FF;
p[x * 3 + 1] := $FF;
p[x * 3 + 2] := $FF;
end;
End
else
begin
For x := 0 To b.width - 1 do
If ((x + 1) Mod 2) = 0 then
begin
p[x * 3] := $FF;
p[x * 3 + 1] := $FF;
p[x * 3 + 2] := $FF;
end;
end;
end;
b.transparent := true;
b.transparentcolor := clwhite;
dst.canvas.draw(0, 0, b);
b.free;
end;

Procedure QuartoOpaque(src, dst: tbitmap);
Var b: tbitmap;
P: Pbytearray;
x, y: integer;
begin
b := tbitmap.create;
b.width := src.width;
b.height := src.height;
b.PixelFormat := pf24bit;
b.canvas.draw(0, 0, src);
For y := 0 To b.height - 1 do
begin
p := b.scanline[y];
If (y Mod 2) = 0 then
begin
For x := 0 To b.width - 1 do
If (x Mod 2) = 0 then
begin
p[x * 3] := $FF;
p[x * 3 + 1] := $FF;
p[x * 3 + 2] := $FF;
end;
End
else
begin
For x := 0 To b.width - 1 do
begin
p[x * 3] := $FF;
p[x * 3 + 1] := $FF;
p[x * 3 + 2] := $FF;
end;

end;
end;
b.transparent := true;
b.transparentcolor := clwhite;
dst.canvas.draw(0, 0, b);
b.free;
end;


Procedure FoldRight(src1, src2, dst: Tbitmap;
amount: extended);
Var
w, h, x, y, xf, xf0: integer;
ps1, ps2, pd: pbytearray;
begin
src1.PixelFormat := pf24bit;
src2.PixelFormat := pf24bit;
w := src1.width;
h := src2.height;
dst.width := w;
dst.height := h;
dst.PixelFormat := pf24bit;
xf := round(amount * w);
For y := 0 To h - 1 do
begin
ps1 := src1.ScanLine[y];
ps2 := src2.scanline[y];
pd := dst.scanline[y];
For x := 0 To xf do
begin
xf0 := xf + (xf - x);
If xf0 < w then
begin
pd[xf0 * 3] := ps1[x * 3];
pd[xf0 * 3 + 1] := ps1[x * 3 + 1];
pd[xf0 * 3 + 2] := ps1[x * 3 + 2];
pd[x * 3] := ps2[x * 3];
pd[x * 3 + 1] := ps2[x * 3 + 1];
pd[x * 3 + 2] := ps2[x * 3 + 2];
end;
end;
If (2 * xf) < w - 1 then
For x := 2 * xf + 1 To w - 1 do
begin
pd[x * 3] := ps1[x * 3];
pd[x * 3 + 1] := ps1[x * 3 + 1];
pd[x * 3 + 2] := ps1[x * 3 + 2];
end;
end;
end;

Procedure MandelBrot(src: Tbitmap;
factor: integer);
Const maxX = 1.25;
minX = -2;
maxY = 1.25;
minY = -1.25;
Var
w, h, x, y, facx, facy: integer;
Sa, Sbi, dx, dy: extended;
p0: pbytearray;
color: integer;
xlo, xhi, ylo, yhi: extended;
Function IsMandel(CA, CBi: extended): integer;
Const MAX_ITERATION = 64;
Var
OLD_A: extended;
{just a variable to keep 'a' from being destroyed}
A, B: extended;
{function Z divided in real and imaginary parts}
LENGTH_Z: extended;
{length of Z, sqrt(length_z)>2 => Z->infinity}
iteration: integer;
begin
A := 0;
{initialize Z(0) = 0}
B := 0;
ITERATION := 0;
{initialize iteration}
Repeat
OLD_A := A;
{saves the 'a' (Will be destroyed in next line}
A := A * A - B * B + CA;
B := 2 * OLD_A * B + CBi;
ITERATION := ITERATION + 1;
LENGTH_Z := A * A + B * B;
Until (LENGTH_Z >= 4) Or (ITERATION > MAX_ITERATION);
result := iteration;
end;

begin
w := src.width;
h := src.height;
src.pixelformat := pf24bit;
dx := (MaxX - MinX) / w;
dy := (Maxy - MinY) / h;
For y := 0 To h - 1 do
begin
p0 := src.ScanLine[y];
For x := 0 To w - 1 do
begin
color := IsMandel(MinX + x * dx, MinY + y * dy);
If color > factor then
color := $FF
else
color := $00;
p0[x * 3] := color;
p0[x * 3 + 1] := color;
p0[x * 3 + 2] := color;
end;
end;
end;

Procedure MaskMandelBrot(src: Tbitmap;
factor: integer);
Var
bm: Tbitmap;
begin
bm := tbitmap.create;
bm.width := src.width;
bm.height := src.height;
MandelBrot(bm, factor);
bm.transparent := true;
bm.transparentcolor := clwhite;
src.canvas.draw(0, 0, bm);
bm.free;
end;

Procedure KeepBlue(src: Tbitmap;
factor: extended);
Var x, y, w, h: integer;
p0: pbytearray;
begin
src.PixelFormat := pf24bit;
w := src.width;
h := src.height;
For y := 0 To h - 1 do
begin
p0 := src.scanline[y];
For x := 0 To w - 1 do
begin
p0[x * 3] := round(factor * p0[x * 3]);
p0[x * 3 + 1] := 0;
p0[x * 3 + 2] := 0;
end;
end;
end;

Procedure KeepGreen(src: Tbitmap;
factor: extended);
Var x, y, w, h: integer;
p0: pbytearray;
begin
src.PixelFormat := pf24bit;
w := src.width;
h := src.height;
For y := 0 To h - 1 do
begin
p0 := src.scanline[y];
For x := 0 To w - 1 do
begin
p0[x * 3 + 1] := round(factor * p0[x * 3 + 1]);
p0[x * 3] := 0;
p0[x * 3 + 2] := 0;
end;
end;
end;

Procedure KeepRed(src: Tbitmap;
factor: extended);
Var x, y, w, h: integer;
p0: pbytearray;
begin
src.PixelFormat := pf24bit;
w := src.width;
h := src.height;
For y := 0 To h - 1 do
begin
p0 := src.scanline[y];
For x := 0 To w - 1 do
begin
p0[x * 3 + 2] := round(factor * p0[x * 3 + 2]);
p0[x * 3 + 1] := 0;
p0[x * 3] := 0;
end;
end;
end;

Procedure Shake(src, dst: Tbitmap;
factor: extended);
Var x, y, h, w, dx: integer;
p: pbytearray;
begin
dst.canvas.draw(0, 0, src);
dst.pixelformat := pf24bit;
w := dst.Width;
h := dst.height;
dx := round(factor * w);
If dx = 0 then
exit;
If dx > (w Div 2) then
exit;
For y := 0 To h - 1 do
begin
p := dst.scanline[y];
If (y Mod 2) = 0 then
For x := dx To w - 1 do
begin
p[(x - dx) * 3] := p[x * 3];
p[(x - dx) * 3 + 1] := p[x * 3 + 1];
p[(x - dx) * 3 + 2] := p[x * 3 + 2];
End
else
For x := w - 1 do
wnto dx do
begin
p[x * 3] := p[(x - dx) * 3];
p[x * 3 + 1] := p[(x - dx) * 3 + 1];
p[x * 3 + 2] := p[(x - dx) * 3 + 2];
end;
end;

end;

Procedure ShakeDown(src, dst: Tbitmap;
factor: extended);
Var x, y, h, w, dy: integer;
p, p2, p3: pbytearray;
begin
dst.canvas.draw(0, 0, src);
dst.pixelformat := pf24bit;
w := dst.Width;
h := dst.height;
dy := round(factor * h);
If dy = 0 then
exit;
If dy > (h Div 2) then
exit;
For y := dy To h - 1 do
begin
p := dst.scanline[y];
p2 := dst.scanline[y - dy];
For x := 0 To w - 1 do
If (x Mod 2) = 0 then
begin
p2[x * 3] := p[x * 3];
p2[x * 3 + 1] := p[x * 3 + 1];
p2[x * 3 + 2] := p[x * 3 + 2];
end;
end;
For y := h - 1 - dy do
wnto 0 do
begin
p := dst.scanline[y];
p3 := dst.scanline[y + dy];
For x := 0 To w - 1 do
If (x Mod 2) <> 0 then
begin
p3[x * 3] := p[x * 3];
p3[x * 3 + 1] := p[x * 3 + 1];
p3[x * 3 + 2] := p[x * 3 + 2];
end;
end;
end;

Procedure Plasma(src1, src2, dst: Tbitmap;
scale, turbulence: extended);
Var
cval, sval: Array[0..255] Of integer;
i, x, y, w, h, xx, yy: integer;
Asin, Acos: extended;
ps1, ps2, pd: pbytearray;
begin
w := src1.width;
h := src1.height;
If turbulence < 10 then
turbulence := 10;
If scale < 5 then
scale := 5;
For i := 0 To 255 do
begin
sincos(i / turbulence, Asin, Acos);
sval := round(-scale * Asin);
cval := round(scale * Acos);
end;
For y := 0 To h - 1 do
begin
pd := dst.scanline[y];
ps2 := src2.scanline[y];
For x := 0 To w - 1 do
begin
xx := x + sval[ps2[x * 3]];
yy := y + cval[ps2[x * 3]];
If (xx >= 0) And (xx < w) And (yy >= 0) And (yy < h) then
begin
ps1 := src1.scanline[yy];
pd[x * 3] := ps1[xx * 3];
pd[x * 3 + 1] := ps1[xx * 3 + 1];
pd[x * 3 + 2] := ps1[xx * 3 + 2];
end;
end;
end;
;
end;

Procedure splitround(src, dst: tbitmap;
amount: integer;
style: TLightBrush);
Var x, y, h, w, c, c00, dx, cx: integer;
R, R00: trect;
bm, bm2: tbitmap;
p0, p00, p1: pbytearray;
begin
If amount = 0 then
begin
dst.canvas.Draw(0, 0, src);
exit;
end;
cx := src.width Div 2;
If amount > cx then
amount := cx;
w := src.width;
bm := tbitmap.create;
bm.PixelFormat := pf24bit;
bm.height := 1;
bm.width := cx;
bm2 := tbitmap.create;
bm2.PixelFormat := pf24bit;
bm2.height := 1;
bm2.width := cx;
p0 := bm.scanline[0];
p00 := bm2.scanline[0];
For y := 0 To src.height - 1 do
begin
p1 := src.scanline[y];
For x := 0 To cx - 1 do
begin
c := x * 3;
c00 := (cx + x) * 3;
p0[c] := p1[c];
p0[c + 1] := p1[c + 1];
p0[c + 2] := p1[c + 2];
p00[c] := p1[c00];
p00[c + 1] := p1[c00 + 1];
p00[c + 2] := p1[c00 + 2];
end;
Case style Of
mbsplitround: dx := round(amount * abs(sin(y / (src.height - 1) * pi)));
mbsplitwaste: dx := round(amount * abs(cos(y / (src.height - 1) * pi)));
end;
R := rect(0, y, dx, y + 1);
dst.Canvas.StretchDraw(R, bm);
R00 := rect(w - 1 - dx, y, w - 1, y + 1);
dst.Canvas.StretchDraw(R00, bm2);
end;
bm.free;
bm2.free;
end;

Procedure Emboss(Var Bmp: TBitmap);
Var
x, y: Integer;
p1, p2: Pbytearray;
begin
For y := 0 To Bmp.Height - 2 do
begin
p1 := bmp.scanline[y];
p2 := bmp.scanline[y + 1];
For x := 0 To Bmp.Width - 4 do
begin
p1[x * 3] := (p1[x * 3] + (p2[(x + 3) * 3] Xor $FF)) Shr 1;
p1[x * 3 + 1] := (p1[x * 3 + 1] + (p2[(x + 3) * 3 + 1] Xor $FF)) Shr 1;
p1[x * 3 + 2] := (p1[x * 3 + 2] + (p2[(x + 3) * 3 + 2] Xor $FF)) Shr 1;
end;
end;

end;

Procedure filterred(src: tbitmap;
min, max: integer);
Var c, x, y: integer;
p1: pbytearray;
begin
For y := 0 To src.height - 1 do
begin
p1 := src.scanline[y];
For x := 0 To src.width - 1 do
begin
c := x * 3;
If (p1[c + 2] > min) And (p1[c + 2] < max) then
p1[c + 2] := $FF
else
p1[c + 2] := 0;
p1[c] := 0;
p1[c + 1] := 0;
end;
end;
end;

Procedure filtergreen(src: tbitmap;
min, max: integer);
Var c, x, y: integer;
p1: pbytearray;
begin
For y := 0 To src.height - 1 do
begin
p1 := src.scanline[y];
For x := 0 To src.width - 1 do
begin
c := x * 3;
If (p1[c + 1] > min) And (p1[c + 1] < max) then
p1[c + 1] := $FF
else
p1[c + 1] := 0;
p1[c] := 0;
p1[c + 2] := 0;
end;
end;
end;

Procedure filterblue(src: tbitmap;
min, max: integer);
Var c, x, y: integer;
p1: pbytearray;
begin
For y := 0 To src.height - 1 do
begin
p1 := src.scanline[y];
For x := 0 To src.width - 1 do
begin
c := x * 3;
If (p1[c] > min) And (p1[c] < max) then
p1[c] := $FF
else
p1[c] := 0;
p1[c + 1] := 0;
p1[c + 2] := 0;
end;
end;
end;

Procedure filterxred(src: tbitmap;
min, max: integer);
Var c, x, y: integer;
p1: pbytearray;
begin
For y := 0 To src.height - 1 do
begin
p1 := src.scanline[y];
For x := 0 To src.width - 1 do
begin
c := x * 3;
If (p1[c + 2] > min) And (p1[c + 2] < max) then
p1[c + 2] := $FF
else
p1[c + 2] := 0;
end;
end;
end;

Procedure filterxgreen(src: tbitmap;
min, max: integer);
Var c, x, y: integer;
p1: pbytearray;
begin
For y := 0 To src.height - 1 do
begin
p1 := src.scanline[y];
For x := 0 To src.width - 1 do
begin
c := x * 3;
If (p1[c + 1] > min) And (p1[c + 1] < max) then
p1[c + 1] := $FF
else
p1[c + 1] := 0;
end;
end;
end;

Procedure filterxblue(src: tbitmap;
min, max: integer);
Var c, x, y: integer;
p1: pbytearray;
begin
For y := 0 To src.height - 1 do
begin
p1 := src.scanline[y];
For x := 0 To src.width - 1 do
begin
c := x * 3;
If (p1[c] > min) And (p1[c] < max) then
p1[c] := $FF
else
p1[c] := 0;
end;
end;
end;

//Just a small function to map the numbers to colors
Function ConvertColor(Value: Integer): TColor;
begin
Case Value Of
0: Result := clBlack;
1: Result := clNavy;
2: Result := clGreen;
3: Result := clAqua;
4: Result := clRed;
5: Result := clPurple;
6: Result := clMaroon;
7: Result := clSilver;
8: Result := clGray;
9: Result := clBlue;
10: Result := clLime;
11: Result := clOlive;
12: Result := clFuchsia;
13: Result := clTeal;
14: Result := clYellow;
15: Result := clWhite;
else
Result := clWhite;
end;
end;

Procedure DrawMandelJulia(src: Tbitmap;
x0, y0, x1, y1: extended;
Niter: integer;
Mandel: Boolean);
Const
//Number if colors. If this is changed, the number of mapped colors must also be changed
nc = 16;
Type
TjvRGBTriplet = Record
r, g, b: byte
end;
Var
X, XX, Y, YY, Cx, Cy, Dx, Dy, XSquared, YSquared: do
uble;
Nx, Ny, Py, Px, I: Integer;
p0: pbytearray;
cc: Array[0..15] Of TjvRGBTriplet;
Acolor: Tcolor;
begin
src.PixelFormat := pf24bit;
For i := 0 To 15 do
begin
Acolor := convertcolor(i);
cc.b := GetBValue(colortoRGB(Acolor));
cc.g := GetGValue(colortoRGB(Acolor));
cc.r := GetRValue(colortoRGB(Acolor));
end;
If Niter < nc then
Niter := nc;
Try
Nx := src.Width;
Ny := src.Height;
Cx := 0;
Cy := 1;
Dx := (x1 - x0) / nx;
Dy := (y1 - y0) / ny;
Py := 0;
While (PY < Ny) do
begin
p0 := src.scanline[py];
PX := 0;
While (Px < Nx) do
begin
x := x0 + px * dx;
y := y0 + py * dy;
If (mandel) then
begin
cx := x;
cy := y;
x := 0;
y := 0;
end;
xsquared := 0;
ysquared := 0;
I := 0;
While (I <= niter) And (xsquared + ysquared < (4)) do
begin
xsquared := x * x;
ysquared := y * y;
xx := xsquared - ysquared + cx;
yy := (2 * x * y) + cy;
x := xx;
y := yy;
I := I + 1;
end;
I := I - 1;
If (i = niter) then
i := 0
else
i := round(i / (niter / nc));
// Canvas.Pixels[PX,PY] := ConvertColor(I);
p0[px * 3] := cc.b;
p0[px * 3 + 1] := cc.g;
p0[px * 3 + 2] := cc.r;
Px := Px + 1;
end;
Py := Py + 1;
end;
Finally
end;
end;

Procedure Invert(src: tbitmap);
Var w, h, x, y: integer;
p: pbytearray;
begin
w := src.width;
h := src.height;
src.PixelFormat := pf24bit;
For y := 0 To h - 1 do
begin
p := src.scanline[y];
For x := 0 To w - 1 do
begin
p[x * 3] := Not p[x * 3];
p[x * 3 + 1] := Not p[x * 3 + 1];
p[x * 3 + 2] := Not p[x * 3 + 2];
end;
end;
end;

Procedure MirrorRight(src: Tbitmap);
Var w, h, x, y: integer;
p: pbytearray;
begin
w := src.width;
h := src.height;
src.PixelFormat := pf24bit;
For y := 0 To h - 1 do
begin
p := src.scanline[y];
For x := 0 To w Div 2 do
begin
p[(w - 1 - x) * 3] := p[x * 3];
p[(w - 1 - x) * 3 + 1] := p[x * 3 + 1];
p[(w - 1 - x) * 3 + 2] := p[x * 3 + 2];
end;
end;
end;

Procedure MirrorDown(src: Tbitmap);
Var w, h, x, y: integer;
p1, p2: pbytearray;
begin
w := src.width;
h := src.height;
src.PixelFormat := pf24bit;
For y := 0 To h Div 2 do
begin
p1 := src.scanline[y];
p2 := src.scanline[h - 1 - y];
For x := 0 To w - 1 do
begin
p2[x * 3] := p1[x * 3];
p2[x * 3 + 1] := p1[x * 3 + 1];
p2[x * 3 + 2] := p1[x * 3 + 2];
end;
end;
end;

// resample image as triangles
Procedure Triangles(src: TBitmap;
amount: integer);
Type
Ttriplet = Record
r, g, b: byte;
end;

Var w, h, x, y, tb, tm, te: integer;
ps: pbytearray;
T: ttriplet;
begin
w := src.width;
h := src.height;
src.PixelFormat := pf24bit;
If amount < 5 then
amount := 5;
amount := (amount Div 2) * 2 + 1;
tm := amount Div 2;
For y := 0 To h - 1 do
begin
ps := src.scanline[y];
t.r := ps[0];
t.g := ps[1];
t.b := ps[2];
tb := y Mod (amount - 1);
If tb > tm then
tb := 2 * tm - tb;
If tb = 0 then
tb := amount;
te := tm + abs(tm - (y Mod amount));
For x := 0 To w - 1 do
begin
If (x Mod tb) = 0 then
begin
t.r := ps[x * 3];
t.g := ps[x * 3 + 1];
t.b := ps[x * 3 + 2];
end;
If ((x Mod te) = 1) And (tb <> 0) then
begin
t.r := ps[x * 3];
t.g := ps[x * 3 + 1];
t.b := ps[x * 3 + 2];
end;
ps[x * 3] := t.r;
ps[x * 3 + 1] := t.g;
ps[x * 3 + 2] := t.b;
end;
end;
end;

Procedure RippleTooth(src: TBitmap;
amount: integer);
Var
c, c2, x, y: integer;
P1, P2: PByteArray;
b: byte;
begin
src.PixelFormat := pf24bit;
amount := min(src.height Div 2, amount);
For y := src.height - 1 - amount do
wnto 0 do
begin
P1 := src.ScanLine[y];
b := 0;
For x := 0 To src.width - 1 do
begin
P2 := src.scanline[y + b];
P2[x * 3] := P1[x * 3];
P2[x * 3 + 1] := P1[x * 3 + 1];
P2[x * 3 + 2] := P1[x * 3 + 2];
inc(b);
If b > amount then
b := 0;
end;
end;
end;

Procedure RippleTriangle(src: TBitmap;
amount: integer);
Var
c, c2, x, y: integer;
P1, P2: PByteArray;
b: byte;
do
inc: boolean;
begin
amount := min(src.height Div 2, amount);
For y := src.height - 1 - amount do
wnto 0 do
begin
P1 := src.ScanLine[y];
b := 0;
do
inc := true;
For x := 0 To src.width - 1 do
begin
P2 := src.scanline[y + b];
P2[x * 3] := P1[x * 3];
P2[x * 3 + 1] := P1[x * 3 + 1];
P2[x * 3 + 2] := P1[x * 3 + 2];
If do
inc then
begin
inc(b);
If b > amount then
begin
do
inc := false;
b := amount - 1;
end;
End
else
begin
If b = 0 then
begin
do
inc := true;
b := 2;
end;
dec(b);
end;
end;
end;
end;

Procedure RippleRandom(src: TBitmap;
amount: integer);
Var
c, c2, x, y: integer;
P1, P2: PByteArray;
b: byte;
begin
amount := min(src.height Div 2, amount);
src.PixelFormat := pf24bit;
randomize;
For y := src.height - 1 - amount do
wnto 0 do
begin
P1 := src.ScanLine[y];
b := 0;
For x := 0 To src.width - 1 do
begin
P2 := src.scanline[y + b];
P2[x * 3] := P1[x * 3];
P2[x * 3 + 1] := P1[x * 3 + 1];
P2[x * 3 + 2] := P1[x * 3 + 2];
b := random(amount);
end;
end;
end;

Procedure TexturizeOverlap(src: TBitmap;
amount: integer);
Var w, h, x, y, xo: integer;
bm: tbitmap;
arect: trect;
begin
bm := tbitmap.create;
amount := min(src.width Div 2, amount);
amount := min(src.height Div 2, amount);
xo := round(amount * 2 / 3);
bm.width := amount;
bm.height := amount;
w := src.width;
h := src.height;
arect := rect(0, 0, amount, amount);
bm.Canvas.StretchDraw(arect, src);
y := 0;
Repeat
x := 0;
Repeat
src.canvas.Draw(x, y, bm);
x := x + xo;
Until x >= w;
y := y + xo;
Until y >= h;
bm.free;
end;

Procedure TexturizeTile(src: TBitmap;
amount: integer);
Var w, h, x, y: integer;
bm: tbitmap;
arect: trect;
begin
bm := tbitmap.create;
amount := min(src.width Div 2, amount);
amount := min(src.height Div 2, amount);
bm.width := amount;
bm.height := amount;
w := src.width;
h := src.height;
arect := rect(0, 0, amount, amount);
bm.Canvas.StretchDraw(arect, src);
y := 0;
Repeat
x := 0;
Repeat
src.canvas.Draw(x, y, bm);
x := x + bm.width;
Until x >= w;
y := y + bm.height;
Until y >= h;
bm.free;
end;

Procedure HeightMap(src: Tbitmap;
amount: integer);
Var bm: tbitmap;
w, h, x, y: integer;
pb, ps: pbytearray;
c: integer;
begin
h := src.height;
w := src.width;
bm := tbitmap.create;
bm.width := w;
bm.height := h;
bm.PixelFormat := pf24bit;
src.PixelFormat := pf24bit;
bm.Canvas.Draw(0, 0, src);
For y := 0 To h - 1 do
begin
pb := bm.ScanLine[y];
For x := 0 To w - 1 do
begin
c := round((pb[x * 3] + pb[x * 3 + 1] + pb[x * 3 + 2]) / 3 / 255 * amount);
If (y - c) >= 0 then
begin
ps := src.ScanLine[y - c];
ps[x * 3] := pb[x * 3];
ps[x * 3 + 1] := pb[x * 3 + 1];
ps[x * 3 + 2] := pb[x * 3 + 2];
end;
end;
end;
bm.free;
end;

Procedure turn(src, dst: tbitmap);
Var w, h, x, y: integer;
ps, pd: pbytearray;
begin
h := src.Height;
w := src.width;
src.PixelFormat := pf24bit;
dst.PixelFormat := pf24bit;
dst.Height := w;
dst.Width := h;
For y := 0 To h - 1 do
begin
ps := src.ScanLine[y];
For x := 0 To w - 1 do
begin
pd := dst.ScanLine[w - 1 - x];
pd[y * 3] := ps[x * 3];
pd[y * 3 + 1] := ps[x * 3 + 1];
pd[y * 3 + 2] := ps[x * 3 + 2];
end;
end;
end;

Procedure turnRight(src, dst: Tbitmap);
Var w, h, x, y: integer;
ps, pd: pbytearray;
begin
h := src.Height;
w := src.width;
src.PixelFormat := pf24bit;
dst.PixelFormat := pf24bit;
dst.Height := w;
dst.Width := h;
For y := 0 To h - 1 do
begin
ps := src.ScanLine[y];
For x := 0 To w - 1 do
begin
pd := dst.ScanLine[x];
pd[(h - 1 - y) * 3] := ps[x * 3];
pd[(h - 1 - y) * 3 + 1] := ps[x * 3 + 1];
pd[(h - 1 - y) * 3 + 2] := ps[x * 3 + 2];
end;
end;
end;

Procedure ExtractColor(src: TBitmap;
Acolor: tcolor);
Var w, h, x, y: integer;
p: pbytearray;
Ecolor: TColor;
r, g, b: byte;
begin
w := src.width;
h := src.height;
Ecolor := colortorgb(Acolor);
r := getRValue(Ecolor);
g := getGValue(Ecolor);
b := getBValue(Ecolor);
src.PixelFormat := pf24bit;
For y := 0 To h - 1 do
begin
p := src.ScanLine[y];
For x := 0 To w - 1 do
begin
If ((p[x * 3] <> b) Or (p[x * 3 + 1] <> g) Or (p[x * 3 + 2] <> r)) then
begin
p[x * 3] := $00;
p[x * 3 + 1] := $00;
p[x * 3 + 2] := $00;
end;
End
end;
src.transparent := true;
src.TransparentColor := clblack;
end;

Procedure ExcludeColor(src: TBitmap;
Acolor: tcolor);
Var w, h, x, y: integer;
p: pbytearray;
Ecolor: TColor;
r, g, b: byte;
begin
w := src.width;
h := src.height;
Ecolor := colortorgb(Acolor);
r := getRValue(Ecolor);
g := getGValue(Ecolor);
b := getBValue(Ecolor);
src.PixelFormat := pf24bit;
For y := 0 To h - 1 do
begin
p := src.ScanLine[y];
For x := 0 To w - 1 do
begin
If ((p[x * 3] = b) And (p[x * 3 + 1] = g) And (p[x * 3 + 2] = r)) then
begin
p[x * 3] := $00;
p[x * 3 + 1] := $00;
p[x * 3 + 2] := $00;
end;
End
end;
src.transparent := true;
src.TransparentColor := clblack;
end;

Procedure Blend(src1, src2, dst: tbitmap;
amount: extended);
Var w, h, x, y: integer;
ps1, ps2, pd: pbytearray;
begin
w := src1.Width;
h := src1.Height;
dst.Width := w;
dst.Height := h;
src1.PixelFormat := pf24bit;
src2.PixelFormat := pf24bit;
dst.PixelFormat := pf24bit;
For y := 0 To h - 1 do
begin
ps1 := src1.ScanLine[y];
ps2 := src2.ScanLine[y];
pd := dst.ScanLine[y];
For x := 0 To w - 1 do
begin
pd[x * 3] := round((1 - amount) * ps1[x * 3] + amount * ps2[x * 3]);
pd[x * 3 + 1] := round((1 - amount) * ps1[x * 3 + 1] + amount * ps2[x * 3 + 1]);
pd[x * 3 + 2] := round((1 - amount) * ps1[x * 3 + 2] + amount * ps2[x * 3 + 2]);
end;
end;
end;

Procedure Solorize(src, dst: tbitmap;
amount: integer);
Var w, h, x, y: integer;
ps, pd: pbytearray;
c: integer;
begin
w := src.width;
h := src.height;
src.PixelFormat := pf24bit;
dst.PixelFormat := pf24bit;
For y := 0 To h - 1 do
begin
ps := src.scanline[y];
pd := dst.scanline[y];
For x := 0 To w - 1 do
begin
c := (ps[x * 3] + ps[x * 3 + 1] + ps[x * 3 + 2]) Div 3;
If c > amount then
begin
pd[x * 3] := 255 - ps[x * 3];
pd[x * 3 + 1] := 255 - ps[x * 3 + 1];
pd[x * 3 + 2] := 255 - ps[x * 3 + 2];
End
else
begin
pd[x * 3] := ps[x * 3];
pd[x * 3 + 1] := ps[x * 3 + 1];
pd[x * 3 + 2] := ps[x * 3 + 2];
end;
end;
end;
end;

Procedure Posterize(src, dst: tbitmap;
amount: integer);
Var w, h, x, y: integer;
ps, pd: pbytearray;
c: integer;
begin
w := src.width;
h := src.height;
src.PixelFormat := pf24bit;
dst.PixelFormat := pf24bit;
For y := 0 To h - 1 do
begin
ps := src.scanline[y];
pd := dst.scanline[y];
For x := 0 To w - 1 do
begin
pd[x * 3] := round(ps[x * 3] / amount) * amount;
pd[x * 3 + 1] := round(ps[x * 3 + 1] / amount) * amount;
pd[x * 3 + 2] := round(ps[x * 3 + 2] / amount) * amount;
end;
end;
end;

{This just forces a value to be 0 - 255 for rgb purposes. I used asm in an
attempt at speed, but I do
n't think it helps much.}
Function Set255(Clr: integer): integer;
Asm
MOV EAX,Clr // store value in EAX register (32-bit register)
CMP EAX,254 // compare it to 254
JG @SETHI // if greater than 254 then
go set to 255 (max value)
CMP EAX,1 // if less than 255, compare to 1
JL @SETLO // if less than 1 go set to 0 (min value)
RET // otherwise it do
esn't change, just exit
@SETHI: // Set value to 255
MOV EAX,255 // Move 255 into the EAX register
RET // Exit (result value is the EAX register value)
@SETLO: // Set value to 0
MOV EAX,0 // Move 0 into EAX register
end;
// Result is in EAX
{The Expand version of a 3 x 3 convolution.
This approach is similar to the mirror version, except that it copies
or duplicates the pixels from the edges to the same edge. This is
probably the best version if you're interested in quality, but do
n't need
a tiled (seamless) image. }
Procedure ConvolveE(ray: Array Of integer;
z: word;
aBmp: TBitmap);
Var
O, T, C, B: pRGBArray;
// Scanlines
x, y: integer;
tBufr: TBitmap;
// temp bitmap for 'enlarged' image
begin
tBufr := TBitmap.Create;
tBufr.Width := aBmp.Width + 2;
// Add a box around the outside...
tBufr.Height := aBmp.Height + 2;
tBufr.PixelFormat := pf24bit;
O := tBufr.ScanLine[0];
// Copy top corner pixels
T := aBmp.ScanLine[0];
O[0] := T[0];
// Left
O[tBufr.Width - 1] := T[aBmp.Width - 1];
// Right
// Copy top lines
tBufr.Canvas.CopyRect(RECT(1, 0, tBufr.Width - 1, 1), aBmp.Canvas,
RECT(0, 0, aBmp.Width, 1));
O := tBufr.ScanLine[tBufr.Height - 1];
// Copy bottom corner pixels
T := aBmp.ScanLine[aBmp.Height - 1];
O[0] := T[0];
O[tBufr.Width - 1] := T[aBmp.Width - 1];
// Copy bottoms
tBufr.Canvas.CopyRect(RECT(1, tBufr.Height - 1, tBufr.Width - 1, tBufr.Height),
aBmp.Canvas, RECT(0, aBmp.Height - 1, aBmp.Width, aBmp.Height));
// Copy rights
tBufr.Canvas.CopyRect(RECT(tBufr.Width - 1, 1, tBufr.Width, tBufr.Height - 1),
aBmp.Canvas, RECT(aBmp.Width - 1, 0, aBmp.Width, aBmp.Height));
// Copy lefts
tBufr.Canvas.CopyRect(RECT(0, 1, 1, tBufr.Height - 1),
aBmp.Canvas, RECT(0, 0, 1, aBmp.Height));
// Now copy main rectangle
tBufr.Canvas.CopyRect(RECT(1, 1, tBufr.Width - 1, tBufr.Height - 1),
aBmp.Canvas, RECT(0, 0, aBmp.Width, aBmp.Height));
// bmp now enlarged and copied, apply convolve
For x := 0 To aBmp.Height - 1 do
begin
// Walk scanlines
O := aBmp.ScanLine[x];
// New Target (Original)
T := tBufr.ScanLine[x];
//old x-1 (Top)
C := tBufr.ScanLine[x + 1];
//old x (Center)
B := tBufr.ScanLine[x + 2];
//old x+1 (Bottom)
// Now do
the main piece
For y := 1 To (tBufr.Width - 2) do
begin
// Walk pixels
O[y - 1].rgbtRed := Set255(
((T[y - 1].rgbtRed * ray[0]) +
(T[y].rgbtRed * ray[1]) + (T[y + 1].rgbtRed * ray[2]) +
(C[y - 1].rgbtRed * ray[3]) +
(C[y].rgbtRed * ray[4]) + (C[y + 1].rgbtRed * ray[5]) +
(B[y - 1].rgbtRed * ray[6]) +
(B[y].rgbtRed * ray[7]) + (B[y + 1].rgbtRed * ray[8])) Div z
);
O[y - 1].rgbtBlue := Set255(
((T[y - 1].rgbtBlue * ray[0]) +
(T[y].rgbtBlue * ray[1]) + (T[y + 1].rgbtBlue * ray[2]) +
(C[y - 1].rgbtBlue * ray[3]) +
(C[y].rgbtBlue * ray[4]) + (C[y + 1].rgbtBlue * ray[5]) +
(B[y - 1].rgbtBlue * ray[6]) +
(B[y].rgbtBlue * ray[7]) + (B[y + 1].rgbtBlue * ray[8])) Div z
);
O[y - 1].rgbtGreen := Set255(
((T[y - 1].rgbtGreen * ray[0]) +
(T[y].rgbtGreen * ray[1]) + (T[y + 1].rgbtGreen * ray[2]) +
(C[y - 1].rgbtGreen * ray[3]) +
(C[y].rgbtGreen * ray[4]) + (C[y + 1].rgbtGreen * ray[5]) +
(B[y - 1].rgbtGreen * ray[6]) +
(B[y].rgbtGreen * ray[7]) + (B[y + 1].rgbtGreen * ray[8])) Div z
);
end;
end;
tBufr.Free;
end;

{The Ignore (basic) version of a 3 x 3 convolution.
The 3 x 3 convolve uses the eight surrounding pixels as part of the
calculation. But, for the pixels on the edges, there is nothing to use
for the top row values. In other words, the leftmost pixel in the 3rd
row, or scanline, has no pixels on its left to use in the calculations.
This version just ignores the outermost edge of the image, and do
esn't
alter those pixels at all. Repeated applications of filters will
eventually cause a pronounced 'border' effect, as those pixels never
change but all others do
. However, this version is simpler, and the
logic is easier to follow. It's the fastest of the three in this
application, and works great if the 'borders' are not an issue. }
Procedure ConvolveI(ray: Array Of integer;
z: word;
aBmp: TBitmap);
Var
O, T, C, B: pRGBArray;
// Scanlines
x, y: integer;
tBufr: TBitmap;
// temp bitmap
begin
tBufr := TBitmap.Create;
CopyMe(tBufr, aBmp);
For x := 1 To aBmp.Height - 2 do
begin
// Walk scanlines
O := aBmp.ScanLine[x];
// New Target (Original)
T := tBufr.ScanLine[x - 1];
//old x-1 (Top)
C := tBufr.ScanLine[x];
//old x (Center)
B := tBufr.ScanLine[x + 1];
//old x+1 (Bottom)
// Now do
the main piece
For y := 1 To (tBufr.Width - 2) do
begin
// Walk pixels
O[y].rgbtRed := Set255(
((T[y - 1].rgbtRed * ray[0]) +
(T[y].rgbtRed * ray[1]) + (T[y + 1].rgbtRed * ray[2]) +
(C[y - 1].rgbtRed * ray[3]) +
(C[y].rgbtRed * ray[4]) + (C[y + 1].rgbtRed * ray[5]) +
(B[y - 1].rgbtRed * ray[6]) +
(B[y].rgbtRed * ray[7]) + (B[y + 1].rgbtRed * ray[8])) Div z
);
O[y].rgbtBlue := Set255(
((T[y - 1].rgbtBlue * ray[0]) +
(T[y].rgbtBlue * ray[1]) + (T[y + 1].rgbtBlue * ray[2]) +
(C[y - 1].rgbtBlue * ray[3]) +
(C[y].rgbtBlue * ray[4]) + (C[y + 1].rgbtBlue * ray[5]) +
(B[y - 1].rgbtBlue * ray[6]) +
(B[y].rgbtBlue * ray[7]) + (B[y + 1].rgbtBlue * ray[8])) Div z
);
O[y].rgbtGreen := Set255(
((T[y - 1].rgbtGreen * ray[0]) +
(T[y].rgbtGreen * ray[1]) + (T[y + 1].rgbtGreen * ray[2]) +
(C[y - 1].rgbtGreen * ray[3]) +
(C[y].rgbtGreen * ray[4]) + (C[y + 1].rgbtGreen * ray[5]) +
(B[y - 1].rgbtGreen * ray[6]) +
(B[y].rgbtGreen * ray[7]) + (B[y + 1].rgbtGreen * ray[8])) Div z
);
end;
end;
tBufr.Free;
end;

{The mirror version of a 3 x 3 convolution.
The 3 x 3 convolve uses the eight surrounding pixels as part of the
calculation. But, for the pixels on the edges, there is nothing to use
for the top row values. In other words, the leftmost pixel in the 3rd
row, or scanline, has no pixels on its left to use in the calculations.
I compensate for this by increasing the size of the bitmap by one pixel
on top, left, bottom, and right. The mirror version is used in an
application that creates seamless tiles, so I copy the opposite sides to
maintain the seamless integrity. }
Procedure ConvolveM(ray: Array Of integer;
z: word;
aBmp: TBitmap);
Var
O, T, C, B: pRGBArray;
// Scanlines
x, y: integer;
tBufr: TBitmap;
// temp bitmap for 'enlarged' image
begin
tBufr := TBitmap.Create;
tBufr.Width := aBmp.Width + 2;
// Add a box around the outside...
tBufr.Height := aBmp.Height + 2;
tBufr.PixelFormat := pf24bit;
O := tBufr.ScanLine[0];
// Copy top corner pixels
T := aBmp.ScanLine[0];
O[0] := T[0];
// Left
O[tBufr.Width - 1] := T[aBmp.Width - 1];
// Right
// Copy bottom line to our top - trying to remain seamless...
tBufr.Canvas.CopyRect(RECT(1, 0, tBufr.Width - 1, 1), aBmp.Canvas,
RECT(0, aBmp.Height - 1, aBmp.Width, aBmp.Height - 2));
O := tBufr.ScanLine[tBufr.Height - 1];
// Copy bottom corner pixels
T := aBmp.ScanLine[aBmp.Height - 1];
O[0] := T[0];
O[tBufr.Width - 1] := T[aBmp.Width - 1];
// Copy top line to our bottom
tBufr.Canvas.CopyRect(RECT(1, tBufr.Height - 1, tBufr.Width - 1, tBufr.Height),
aBmp.Canvas, RECT(0, 0, aBmp.Width, 1));
// Copy left to our right
tBufr.Canvas.CopyRect(RECT(tBufr.Width - 1, 1, tBufr.Width, tBufr.Height - 1),
aBmp.Canvas, RECT(0, 0, 1, aBmp.Height));
// Copy right to our left
tBufr.Canvas.CopyRect(RECT(0, 1, 1, tBufr.Height - 1),
aBmp.Canvas, RECT(aBmp.Width - 1, 0, aBmp.Width, aBmp.Height));
// Now copy main rectangle
tBufr.Canvas.CopyRect(RECT(1, 1, tBufr.Width - 1, tBufr.Height - 1),
aBmp.Canvas, RECT(0, 0, aBmp.Width, aBmp.Height));
// bmp now enlarged and copied, apply convolve
For x := 0 To aBmp.Height - 1 do
begin
// Walk scanlines
O := aBmp.ScanLine[x];
// New Target (Original)
T := tBufr.ScanLine[x];
//old x-1 (Top)
C := tBufr.ScanLine[x + 1];
//old x (Center)
B := tBufr.ScanLine[x + 2];
//old x+1 (Bottom)
// Now do
the main piece
For y := 1 To (tBufr.Width - 2) do
begin
// Walk pixels
O[y - 1].rgbtRed := Set255(
((T[y - 1].rgbtRed * ray[0]) +
(T[y].rgbtRed * ray[1]) + (T[y + 1].rgbtRed * ray[2]) +
(C[y - 1].rgbtRed * ray[3]) +
(C[y].rgbtRed * ray[4]) + (C[y + 1].rgbtRed * ray[5]) +
(B[y - 1].rgbtRed * ray[6]) +
(B[y].rgbtRed * ray[7]) + (B[y + 1].rgbtRed * ray[8])) Div z
);
O[y - 1].rgbtBlue := Set255(
((T[y - 1].rgbtBlue * ray[0]) +
(T[y].rgbtBlue * ray[1]) + (T[y + 1].rgbtBlue * ray[2]) +
(C[y - 1].rgbtBlue * ray[3]) +
(C[y].rgbtBlue * ray[4]) + (C[y + 1].rgbtBlue * ray[5]) +
(B[y - 1].rgbtBlue * ray[6]) +
(B[y].rgbtBlue * ray[7]) + (B[y + 1].rgbtBlue * ray[8])) Div z
);
O[y - 1].rgbtGreen := Set255(
((T[y - 1].rgbtGreen * ray[0]) +
(T[y].rgbtGreen * ray[1]) + (T[y + 1].rgbtGreen * ray[2]) +
(C[y - 1].rgbtGreen * ray[3]) +
(C[y].rgbtGreen * ray[4]) + (C[y + 1].rgbtGreen * ray[5]) +
(B[y - 1].rgbtGreen * ray[6]) +
(B[y].rgbtGreen * ray[7]) + (B[y + 1].rgbtGreen * ray[8])) Div z
);
end;
end;
tBufr.Free;
end;

Procedure Seamless(src: TBitmap;
depth: byte);
Var
p1, p2: pbytearray;
w, w3, h, i, x, x3, y: integer;
am, amount: extended;
begin
w := src.width;
h := src.height;
src.PixelFormat := pf24bit;
If depth = 0 then
exit;
am := 1 / depth;
For y := 0 To depth do
begin
p1 := src.ScanLine[y];
p2 := src.ScanLine[h - y - 1];
amount := 1 - y * am;
For x := y To w - 1 - y do
begin
x3 := x * 3;
p2[x3] := round((1 - amount) * p2[x3] + amount * p1[x3]);
p2[x3 + 1] := round((1 - amount) * p2[x3 + 1] + amount * p1[x3 + 1]);
p2[x3 + 2] := round((1 - amount) * p2[x3 + 2] + amount * p1[x3 + 2]);
end;
For x := 0 To y do
begin
amount := 1 - x * am;
x3 := x * 3;
w3 := (w - 1 - x) * 3;
p1[w3] := round((1 - amount) * p1[w3] + amount * p1[x3]);
p1[w3 + 1] := round((1 - amount) * p1[w3 + 1] + amount * p1[x3 + 1]);
p1[w3 + 2] := round((1 - amount) * p1[w3 + 2] + amount * p1[x3 + 2]);
p2[w3] := round((1 - amount) * p2[w3] + amount * p2[x3]);
p2[w3 + 1] := round((1 - amount) * p2[w3 + 1] + amount * p2[x3 + 1]);
p2[w3 + 2] := round((1 - amount) * p2[w3 + 2] + amount * p2[x3 + 2]);
end;
end;
For y := depth To h - 1 - depth do
begin
p1 := src.ScanLine[y];
For x := 0 To depth do
begin
x3 := x * 3;
w3 := (w - 1 - x) * 3;
amount := 1 - x * am;
p1[w3] := round((1 - amount) * p1[w3] + amount * p1[x3]);
p1[w3 + 1] := round((1 - amount) * p1[w3 + 1] + amount * p1[x3 + 1]);
p1[w3 + 2] := round((1 - amount) * p1[w3 + 2] + amount * p1[x3 + 2]);
end;
end;
end;

Procedure Buttonize(src: TBitmap;
depth: byte;
weight: integer);
Var
p1, p2: pbytearray;
w, w3, h, i, x, x3, y: integer;
am, amount: extended;
a, r, g, b: Integer;
begin
a := weight;
//
w := src.width;
h := src.height;
src.PixelFormat := pf24bit;
If depth = 0 then
exit;
For y := 0 To depth do
begin
p1 := src.ScanLine[y];
p2 := src.ScanLine[h - y - 1];
// amount:=1-y*am;
For x := y To w - 1 - y do
begin
x3 := x * 3;
// lighter
r := p1[x3];
g := p1[x3 + 1];
b := p1[x3 + 2];
p1[x3] := IntToByte(r + ((255 - r) * a) Div 255);
p1[x3 + 1] := IntToByte(g + ((255 - g) * a) Div 255);
p1[x3 + 2] := IntToByte(b + ((255 - b) * a) Div 255);
// darker
r := p2[x3];
g := p2[x3 + 1];
b := p2[x3 + 2];
p2[x3] := IntToByte(r - ((r) * a) Div 255);
p2[x3 + 1] := IntToByte(g - ((g) * a) Div 255);
p2[x3 + 2] := IntToByte(b - ((b) * a) Div 255);
end;
For x := 0 To y do
begin
x3 := x * 3;
w3 := (w - 1 - x) * 3;
// lighter left
r := p1[x3];
g := p1[x3 + 1];
b := p1[x3 + 2];
p1[x3] := IntToByte(r + ((255 - r) * a) Div 255);
p1[x3 + 1] := IntToByte(g + ((255 - g) * a) Div 255);
p1[x3 + 2] := IntToByte(b + ((255 - b) * a) Div 255);
// darker right
r := p1[w3];
g := p1[w3 + 1];
b := p1[w3 + 2];
p1[w3] := IntToByte(r - ((r) * a) Div 255);
p1[w3 + 1] := IntToByte(g - ((g) * a) Div 255);
p1[w3 + 2] := IntToByte(b - ((b) * a) Div 255);
// lighter bottom left
r := p2[x3];
g := p2[x3 + 1];
b := p2[x3 + 2];
p2[x3] := IntToByte(r + ((255 - r) * a) Div 255);
p2[x3 + 1] := IntToByte(g + ((255 - g) * a) Div 255);
p2[x3 + 2] := IntToByte(b + ((255 - b) * a) Div 255);
// darker bottom right
r := p2[w3];
g := p2[w3 + 1];
b := p2[w3 + 2];
p2[w3] := IntToByte(r - ((r) * a) Div 255);
p2[w3 + 1] := IntToByte(g - ((g) * a) Div 255);
p2[w3 + 2] := IntToByte(b - ((b) * a) Div 255);
end;
end;
For y := depth + 1 To h - 2 - depth do
begin
p1 := src.ScanLine[y];
For x := 0 To depth do
begin
x3 := x * 3;
w3 := (w - 1 - x) * 3;
// lighter left
r := p1[x3];
g := p1[x3 + 1];
b := p1[x3 + 2];
p1[x3] := IntToByte(r + ((255 - r) * a) Div 255);
p1[x3 + 1] := IntToByte(g + ((255 - g) * a) Div 255);
p1[x3 + 2] := IntToByte(b + ((255 - b) * a) Div 255);
// darker right
r := p1[w3];
g := p1[w3 + 1];
b := p1[w3 + 2];
p1[w3] := IntToByte(r - ((r) * a) Div 255);
p1[w3 + 1] := IntToByte(g - ((g) * a) Div 255);
p1[w3 + 2] := IntToByte(b - ((b) * a) Div 255);
end;
end;
end;


Procedure ConvolveFilter(filternr, edgenr: integer;
src: TBitmap);
Var
z: integer;
ray: Array[0..8] Of integer;
OrigBMP: TBitmap;
// Bitmap for temporary use
begin
z := 1;
// just to avoid compiler warnings!
Case filternr Of
0: begin
// Laplace
ray[0] := -1;
ray[1] := -1;
ray[2] := -1;
ray[3] := -1;
ray[4] := 8;
ray[5] := -1;
ray[6] := -1;
ray[7] := -1;
ray[8] := -1;
z := 1;
end;
1: begin
// Hipass
ray[0] := -1;
ray[1] := -1;
ray[2] := -1;
ray[3] := -1;
ray[4] := 9;
ray[5] := -1;
ray[6] := -1;
ray[7] := -1;
ray[8] := -1;
z := 1;
end;
2: begin
// Find Edges (top do
wn)
ray[0] := 1;
ray[1] := 1;
ray[2] := 1;
ray[3] := 1;
ray[4] := -2;
ray[5] := 1;
ray[6] := -1;
ray[7] := -1;
ray[8] := -1;
z := 1;
end;
3: begin
// Sharpen
ray[0] := -1;
ray[1] := -1;
ray[2] := -1;
ray[3] := -1;
ray[4] := 16;
ray[5] := -1;
ray[6] := -1;
ray[7] := -1;
ray[8] := -1;
z := 8;
end;
4: begin
// Edge Enhance
ray[0] := 0;
ray[1] := -1;
ray[2] := 0;
ray[3] := -1;
ray[4] := 5;
ray[5] := -1;
ray[6] := 0;
ray[7] := -1;
ray[8] := 0;
z := 1;
end;
5: begin
// Color Emboss (Sorta)
ray[0] := 1;
ray[1] := 0;
ray[2] := 1;
ray[3] := 0;
ray[4] := 0;
ray[5] := 0;
ray[6] := 1;
ray[7] := 0;
ray[8] := -2;
z := 1;
end;
6: begin
// Soften
ray[0] := 2;
ray[1] := 2;
ray[2] := 2;
ray[3] := 2;
ray[4] := 0;
ray[5] := 2;
ray[6] := 2;
ray[7] := 2;
ray[8] := 2;
z := 16;
end;
7: begin
// Blur
ray[0] := 3;
ray[1] := 3;
ray[2] := 3;
ray[3] := 3;
ray[4] := 8;
ray[5] := 3;
ray[6] := 3;
ray[7] := 3;
ray[8] := 3;
z := 32;
end;
8: begin
// Soften less
ray[0] := 0;
ray[1] := 1;
ray[2] := 0;
ray[3] := 1;
ray[4] := 2;
ray[5] := 1;
ray[6] := 0;
ray[7] := 1;
ray[8] := 0;
z := 6;
end;
else
exit;
end;
OrigBMP := TBitmap.Create;
// Copy image to 24-bit bitmap
CopyMe(OrigBMP, src);
Case Edgenr Of
0: ConvolveM(ray, z, OrigBMP);
1: ConvolveE(ray, z, OrigBMP);
2: ConvolveI(ray, z, OrigBMP);
end;
src.Assign(OrigBMP);
// Assign filtered image to Image1
OrigBMP.Free;
end;

Procedure CopyMe(tobmp: TBitmap;
frbmp: TGraphic);
begin
tobmp.Width := frbmp.Width;
tobmp.Height := frbmp.Height;
tobmp.PixelFormat := pf24bit;
tobmp.Canvas.Draw(0, 0, frbmp);
end;


Procedure ButtonizeOval(src: TBitmap;
depth: byte;
weight: integer;
rim: String);
Var
p0, p1, p2, p3: pbytearray;
w, w3, h, i, x, x3, y, w2, h2: integer;
am, amount: extended;
fac, a, r, g, b, r2, g2, b2: Integer;
contour: Tbitmap;
biclight, bicdark, bicnone: byte;
act: boolean;
begin
a := weight;
w := src.width;
h := src.height;
contour := Tbitmap.create;
contour.width := w;
contour.height := h;
contour.PixelFormat := pf24bit;
contour.Canvas.brush.color := clwhite;
contour.canvas.FillRect(Rect(0, 0, w, h));
With contour.canvas do
begin
pen.Width := 1;
pen.style := pssolid;
For i := 0 To depth - 1 do
begin
If rim = 'rimmed' then
begin
// (bottom-right)
pen.color := rgb($00, $02, i);
Arc(i, i, w - i, h - i, // ellipse
0, h, // start
w, 0);
// end
// (top-left)
Pen.Color := rgb($00, $01, i);
Arc(i, i, w - i, h - i, // ellipse
w, 0, // start
0, h);
// end
End
else
If (rim = 'round') Or (rim = 'doubleround') then
begin
// (bottom-right)
pen.color := rgb($00, $01, depth - 1 - i);
Arc(i, i, w - i, h - i, // ellipse
0, h, // start
w, 0);
// end
// (top-left)
Pen.Color := rgb($00, $02, depth - 1 - i);
Arc(i, i, w - i, h - i, // ellipse
w, 0, // start
0, h);
// end
end;
end;
If rim = 'doubleround' then
For i := depth To depth - 1 + depth do
begin
// (bottom-right)
pen.color := rgb($00, $02, i);
Arc(i, i, w - i, h - i, // ellipse
0, h, // start
w, 0);
// end
// (top-left)
Pen.Color := rgb($00, $01, i);
Arc(i, i, w - i, h - i, // ellipse
w, 0, // start
0, h);
// end
end;
end;
src.PixelFormat := pf24bit;
For y := 0 To h - 1 do
begin
p1 := src.ScanLine[y];
p2 := contour.scanline[y];
For x := 0 To w - 1 do
begin
x3 := x * 3;
r := p1[x3];
g := p1[x3 + 1];
b := p1[x3 + 2];
r2 := p2[x3];
g2 := p2[x3 + 1];
b2 := p2[x3 + 2];
fac := trunc(r2 / depth * a);
If g2 = $02 then
begin
// lighter
p1[x3] := IntToByte(r + ((255 - r) * fac) Div 255);
p1[x3 + 1] := IntToByte(g + ((255 - g) * fac) Div 255);
p1[x3 + 2] := IntToByte(b + ((255 - b) * fac) Div 255);
End
else
If g2 = $01 then
begin
// darker
p1[x3] := IntToByte(r - ((r) * fac) Div 255);
p1[x3 + 1] := IntToByte(g - ((g) * fac) Div 255);
p1[x3 + 2] := IntToByte(b - ((b) * fac) Div 255);
end;
end;
end;
// anti alias
For y := 1 To h - 2 do
begin
p0 := src.ScanLine[y - 1];
p1 := src.scanline[y];
p2 := src.ScanLine[y + 1];
p3 := contour.scanline[y];
For x := 1 To w - 2 do
begin
g2 := p3[x * 3 + 1];
If g2 <> $00 then
begin
p1[x * 3] := (p0[x * 3] + p2[x * 3] + p1[(x - 1) * 3] + p1[(x + 1) * 3]) Div 4;
p1[x3 + 1] := (p0[x * 3 + 1] + p2[x * 3 + 1] + p1[(x - 1) * 3 + 1] + p1[(x + 1) * 3 + 1]) Div 4;
p1[x * 3 + 2] := (p0[x * 3 + 2] + p2[x * 3 + 2] + p1[(x - 1) * 3 + 2] + p1[(x + 1) * 3 + 2]) Div 4;
end;
end;
end;
contour.free;
end;


Procedure MaskOval(src: TBitmap;
acolor: TColor);
Var
p0, p1, p2, p3: pbytearray;
w, w3, h, i, x, x3, y, w2, h2: integer;
fac, a, r, g, b, r2, g2, b2: Integer;
mr, mg, mb: byte;
contour: Tbitmap;
begin
acolor := colortorgb(acolor);
mr := getRvalue(acolor);
mg := getGvalue(acolor);
mb := getBvalue(acolor);
w := src.width;
h := src.height;
contour := Tbitmap.create;
contour.width := w;
contour.height := h;
contour.PixelFormat := pf24bit;
contour.Canvas.brush.color := clblack;
contour.canvas.FillRect(Rect(0, 0, w, h));
contour.canvas.pen.color := clred;
contour.canvas.brush.color := clred;
contour.canvas.Ellipse(0, 0, w, h);
src.PixelFormat := pf24bit;
For y := 0 To h - 1 do
begin
p1 := src.ScanLine[y];
p2 := contour.scanline[y];
For x := 0 To w - 1 do
begin
x3 := x * 3;
r := p1[x3];
g := p1[x3 + 1];
b := p1[x3 + 2];
r2 := p2[x3];
g2 := p2[x3 + 1];
b2 := p2[x3 + 2];
If b2 = $00 then
begin
// mask
p1[x3] := mb;
p1[x3 + 1] := mg;
p1[x3 + 2] := mr;
end;
end;
end;
contour.free;
end;


end.
 
后退
顶部