Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Added graphics32 library (for antialiased drawing support later on). |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | develop |
Files: | files | file ages | folders |
SHA1: |
7323bcc505527fe670d590b15c76327c |
User & Date: | tinus 2018-06-16 07:49:31.101 |
Context
2018-06-17
| ||
07:08 | Line endings. Leaf check-in: 8e68f6e19e user: tinus tags: develop | |
2018-06-16
| ||
07:49 | Added graphics32 library (for antialiased drawing support later on). check-in: 7323bcc505 user: tinus tags: develop | |
2017-06-11
| ||
09:15 | WHEEL_DELTA op 12 ipv 120 gezet voor andere platforms dan Windows. check-in: a95a6beff5 user: tinus tags: develop | |
Changes
Changes to .fossil-settings/ignore-glob.
1 2 3 4 5 | *.bak src/lib/ src/*.lps src/tekening src/tekening.exe | > > | 1 2 3 4 5 6 7 | */__history/ *.bak src/lib/ src/*.lps src/tekening src/tekening.exe src/tekening.ini |
Added src/graphics32/Contributors.txt.
> > | 1 2 | For a list of contributors please have a look into the Graphics32.chm file or the Graphics32 HTML documentation. |
Added src/graphics32/GR32.inc.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 | (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Andre Beckedorf <Andre@metaException.de> * Michael Hansen <dyster_tid@hotmail.com> * Christian Budde <Christian@aixcoustic.com> * * ***** END LICENSE BLOCK ***** *) {$I GR32_Compiler.inc} (* Symbol PUREPASCAL: ------------------ Forces GR32 into pure pascal mode. Should be used only for testing and debugging purposes. (Defined by default for FPC and DARWIN targets in GR32_Compilers.INC.) *) {-$DEFINE PUREPASCAL} (* Symbol DEPRECATEDMODE : ----------------------- Defines if GR32 should behave like version 1.7.x and down. NOTE: Support for this will be dropped at some time and is only provided for transition *) {-$DEFINE DEPRECATEDMODE} (* Symbol CHANGED_IN_PIXELS : -------------------------- Defines if the OnChange / OnAreaChange event should be fired with safe pixel setters (PixelS, PixelTS, PixelFS etc.) NOTE: While enabling this feature is generally better for the repaint and layer optimization, in "lazy code" it is also much slower. *) {-$DEFINE CHANGED_IN_PIXELS} (* Symbol USEINLINING : -------------------- Defines whether to use function inlining. NOTE: Enabling this symbol increases executable size but will probably result in better performance in most cases. *) {$IFDEF INLININGSUPPORTED} {$DEFINE USEINLINING} {$ENDIF} (* Symbol USE_GUIDS_IN_MMF : ------------------------- Defines whether to use GUIDs for temporary MMFs filename instead of using the GetTempFilename in WinAPI. *) {-$DEFINE USE_GUIDS_IN_MMF} (* Symbol USEMOVE : ---------------- Defines whether to use Move instead of MoveLongword. *) {-$DEFINE USEMOVE} (* Symbol XPTHEMES : ----------------- Enable support for windows xp themes. Eventually undefine if GR32 should be used within a DLL *) {$DEFINE XPTHEMES} (* Symbol USEMULTITHREADING : -------------------------- Use multithreading by default if possible. *) {-$DEFINE USEMULTITHREADING} (* FastCode specific symbols: Adding these symbols to your project's define list will force use of the particular routine over the standard GR32 routine. GR32_FASTCODEMOVE - Uses the patched Move routine rather than MoveLongword. For more information on the FastCode project take a look at this URL: http://fastcode.sourceforge.net/ For FastMove make sure to download the CPU id based function, ie. runtime RTL patching. *) {-$DEFINE GR32_FASTCODEMOVE} {$IFDEF GR32_FASTCODEMOVE} {$DEFINE USEMOVE} {$ENDIF} (* Symbol OMIT_MMX: ---------------- If defined MMX optimizations are not used (omitted) For faster pixel/color processing, MMX can be used which results in a huge performance boost over PUREPASCAL code or native assembler code. However, there's a penalty (a call to EMMS) when switching between FPU and MMX registers. This call is not necessary when SSE2 is available. Though, for backward compatibility it is necessary to call EMMS even if SSE2 is used. NOTE: On every x64 system SSE2 is available and thus MMX support is not necessary. In fact it is problematic in case the Delphi XE2 compiler is used. *) {-$DEFINE OMIT_MMX} {$IFDEF TARGET_x64} {$DEFINE OMIT_MMX} {$ENDIF} (* Symbol OMIT_SSE2: ---------------- If defined SSE2 optimizations are not used (omitted) For faster pixel/color processing, SSE2 can be used which results in a huge performance boost over PUREPASCAL code or native assembler code. *) {-$DEFINE OMIT_SSE2} (* Symbol: USEGR32GAMMA -------------------- If defined the polygon rasterizer will use the GR32 gamma correction LUT. Disable for a slight performance increase. *) {$DEFINE USEGR32GAMMA} (* Symbol: CHANGENOTIFICATIONS --------------------------- If defined the polygon rasterizer will trigger change notifications. Undefining this will avoid bounding box computations, which may improve performance slightly. *) {$DEFINE CHANGENOTIFICATIONS} (* Symbol: USESTACKALLOC --------------------- If defined stack allocation routines will be used in some functions. Allocating memory on the stack is usually more efficient than using the memory manager. If a routine uses StackAllock/StackFree then it should always be wrapped inside a {$W+}...{$W-} block in order to generate a stack frame. NOTE: Undefine this symbol if you get stack overflow errors. *) {-$DEFINE USESTACKALLOC} (* Symbol: RGBA_FORMAT ------------------- Assume RGBA pixel format instead of BGRA (used by e.g. OpenGL.) *) {-$DEFINE RGBA_FORMAT} (* Symbol: NOHINTING ----------------- Disables font hinting by default when using TextToPath() method. It is usually preferrable to disable hinting when using a high quality polygon renderer like VPR. However, hinting can sometimes improve visual quality when rendering small text (text is adjusted to pixel boundaries which makes it more crisp.) *) {$DEFINE NOHINTING} (* Symbol: NOHORIZONTALHINTING --------------------------- Disables horizontal font hinting when using TextToPath() method. The following should not be used in conjunction with NOHINTING. It will attempt to address the problem of extreme font hinting in the GDI by disabling horizontal, but keeping vertical hinting. *) {-$DEFINE NOHORIZONTALHINTING} (* Symbol: USEKERNING ----------------- Enables font kerning when using TextToPath() method. Kerning is the process of adjusting the spacing between characters in a proportional font, usually to achieve a visually pleasing result. However, parsing for kerning pairs is quite expensive in terms of CPU usage while the effect is often very little. Thus kerning is not enabled by default. *) {-$DEFINE USEKERNING} {-$DEFINE TEST_BLENDMEMRGB128SSE4} |
Added src/graphics32/GR32.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 | unit GR32; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Michael Hansen <dyster_tid@hotmail.com> * Andre Beckedorf <Andre@metaException.de> * Mattias Andersson <mattias@centaurix.com> * J. Tulach <tulach at position.cz> * Jouni Airaksinen <markvera at spacesynth.net> * Timothy Weber <teejaydub at users.sourceforge.net> * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LCLType, Types, {$ELSE} {$IFDEF COMPILERXE2_UP}UITypes, Types, {$ENDIF} Windows, {$ENDIF} Controls, Graphics, Classes, SysUtils; { Version Control } const Graphics32Version = '2.0.0 alpha'; { 32-bit Color } type PColor32 = ^TColor32; TColor32 = type Cardinal; PColor32Array = ^TColor32Array; TColor32Array = array [0..0] of TColor32; TArrayOfColor32 = array of TColor32; {$IFNDEF RGBA_FORMAT} TColor32Component = (ccBlue, ccGreen, ccRed, ccAlpha); {$ELSE} TColor32Component = (ccRed, ccGreen, ccBlue, ccAlpha); {$ENDIF} TColor32Components = set of TColor32Component; PColor32Entry = ^TColor32Entry; TColor32Entry = packed record case Integer of {$IFNDEF RGBA_FORMAT} 0: (B, G, R, A: Byte); {$ELSE} 0: (R, G, B, A: Byte); {$ENDIF} 1: (ARGB: TColor32); 2: (Planes: array[0..3] of Byte); 3: (Components: array[TColor32Component] of Byte); end; PColor32EntryArray = ^TColor32EntryArray; TColor32EntryArray = array [0..0] of TColor32Entry; TArrayOfColor32Entry = array of TColor32Entry; PPalette32 = ^TPalette32; TPalette32 = array [Byte] of TColor32; const // Some predefined color constants clBlack32 = TColor32($FF000000); clDimGray32 = TColor32($FF3F3F3F); clGray32 = TColor32($FF7F7F7F); clLightGray32 = TColor32($FFBFBFBF); clWhite32 = TColor32($FFFFFFFF); clMaroon32 = TColor32($FF7F0000); clGreen32 = TColor32($FF007F00); clOlive32 = TColor32($FF7F7F00); clNavy32 = TColor32($FF00007F); clPurple32 = TColor32($FF7F007F); clTeal32 = TColor32($FF007F7F); clRed32 = TColor32($FFFF0000); clLime32 = TColor32($FF00FF00); clYellow32 = TColor32($FFFFFF00); clBlue32 = TColor32($FF0000FF); clFuchsia32 = TColor32($FFFF00FF); clAqua32 = TColor32($FF00FFFF); clAliceBlue32 = TColor32($FFF0F8FF); clAntiqueWhite32 = TColor32($FFFAEBD7); clAquamarine32 = TColor32($FF7FFFD4); clAzure32 = TColor32($FFF0FFFF); clBeige32 = TColor32($FFF5F5DC); clBisque32 = TColor32($FFFFE4C4); clBlancheDalmond32 = TColor32($FFFFEBCD); clBlueViolet32 = TColor32($FF8A2BE2); clBrown32 = TColor32($FFA52A2A); clBurlyWood32 = TColor32($FFDEB887); clCadetblue32 = TColor32($FF5F9EA0); clChartReuse32 = TColor32($FF7FFF00); clChocolate32 = TColor32($FFD2691E); clCoral32 = TColor32($FFFF7F50); clCornFlowerBlue32 = TColor32($FF6495ED); clCornSilk32 = TColor32($FFFFF8DC); clCrimson32 = TColor32($FFDC143C); clDarkBlue32 = TColor32($FF00008B); clDarkCyan32 = TColor32($FF008B8B); clDarkGoldenRod32 = TColor32($FFB8860B); clDarkGray32 = TColor32($FFA9A9A9); clDarkGreen32 = TColor32($FF006400); clDarkGrey32 = TColor32($FFA9A9A9); clDarkKhaki32 = TColor32($FFBDB76B); clDarkMagenta32 = TColor32($FF8B008B); clDarkOliveGreen32 = TColor32($FF556B2F); clDarkOrange32 = TColor32($FFFF8C00); clDarkOrchid32 = TColor32($FF9932CC); clDarkRed32 = TColor32($FF8B0000); clDarkSalmon32 = TColor32($FFE9967A); clDarkSeaGreen32 = TColor32($FF8FBC8F); clDarkSlateBlue32 = TColor32($FF483D8B); clDarkSlateGray32 = TColor32($FF2F4F4F); clDarkSlateGrey32 = TColor32($FF2F4F4F); clDarkTurquoise32 = TColor32($FF00CED1); clDarkViolet32 = TColor32($FF9400D3); clDeepPink32 = TColor32($FFFF1493); clDeepSkyBlue32 = TColor32($FF00BFFF); clDodgerBlue32 = TColor32($FF1E90FF); clFireBrick32 = TColor32($FFB22222); clFloralWhite32 = TColor32($FFFFFAF0); clGainsBoro32 = TColor32($FFDCDCDC); clGhostWhite32 = TColor32($FFF8F8FF); clGold32 = TColor32($FFFFD700); clGoldenRod32 = TColor32($FFDAA520); clGreenYellow32 = TColor32($FFADFF2F); clGrey32 = TColor32($FF808080); clHoneyDew32 = TColor32($FFF0FFF0); clHotPink32 = TColor32($FFFF69B4); clIndianRed32 = TColor32($FFCD5C5C); clIndigo32 = TColor32($FF4B0082); clIvory32 = TColor32($FFFFFFF0); clKhaki32 = TColor32($FFF0E68C); clLavender32 = TColor32($FFE6E6FA); clLavenderBlush32 = TColor32($FFFFF0F5); clLawnGreen32 = TColor32($FF7CFC00); clLemonChiffon32 = TColor32($FFFFFACD); clLightBlue32 = TColor32($FFADD8E6); clLightCoral32 = TColor32($FFF08080); clLightCyan32 = TColor32($FFE0FFFF); clLightGoldenRodYellow32= TColor32($FFFAFAD2); clLightGreen32 = TColor32($FF90EE90); clLightGrey32 = TColor32($FFD3D3D3); clLightPink32 = TColor32($FFFFB6C1); clLightSalmon32 = TColor32($FFFFA07A); clLightSeagreen32 = TColor32($FF20B2AA); clLightSkyblue32 = TColor32($FF87CEFA); clLightSlategray32 = TColor32($FF778899); clLightSlategrey32 = TColor32($FF778899); clLightSteelblue32 = TColor32($FFB0C4DE); clLightYellow32 = TColor32($FFFFFFE0); clLtGray32 = TColor32($FFC0C0C0); clMedGray32 = TColor32($FFA0A0A4); clDkGray32 = TColor32($FF808080); clMoneyGreen32 = TColor32($FFC0DCC0); clLegacySkyBlue32 = TColor32($FFA6CAF0); clCream32 = TColor32($FFFFFBF0); clLimeGreen32 = TColor32($FF32CD32); clLinen32 = TColor32($FFFAF0E6); clMediumAquamarine32 = TColor32($FF66CDAA); clMediumBlue32 = TColor32($FF0000CD); clMediumOrchid32 = TColor32($FFBA55D3); clMediumPurple32 = TColor32($FF9370DB); clMediumSeaGreen32 = TColor32($FF3CB371); clMediumSlateBlue32 = TColor32($FF7B68EE); clMediumSpringGreen32 = TColor32($FF00FA9A); clMediumTurquoise32 = TColor32($FF48D1CC); clMediumVioletRed32 = TColor32($FFC71585); clMidnightBlue32 = TColor32($FF191970); clMintCream32 = TColor32($FFF5FFFA); clMistyRose32 = TColor32($FFFFE4E1); clMoccasin32 = TColor32($FFFFE4B5); clNavajoWhite32 = TColor32($FFFFDEAD); clOldLace32 = TColor32($FFFDF5E6); clOliveDrab32 = TColor32($FF6B8E23); clOrange32 = TColor32($FFFFA500); clOrangeRed32 = TColor32($FFFF4500); clOrchid32 = TColor32($FFDA70D6); clPaleGoldenRod32 = TColor32($FFEEE8AA); clPaleGreen32 = TColor32($FF98FB98); clPaleTurquoise32 = TColor32($FFAFEEEE); clPaleVioletred32 = TColor32($FFDB7093); clPapayaWhip32 = TColor32($FFFFEFD5); clPeachPuff32 = TColor32($FFFFDAB9); clPeru32 = TColor32($FFCD853F); clPlum32 = TColor32($FFDDA0DD); clPowderBlue32 = TColor32($FFB0E0E6); clRosyBrown32 = TColor32($FFBC8F8F); clRoyalBlue32 = TColor32($FF4169E1); clSaddleBrown32 = TColor32($FF8B4513); clSalmon32 = TColor32($FFFA8072); clSandyBrown32 = TColor32($FFF4A460); clSeaGreen32 = TColor32($FF2E8B57); clSeaShell32 = TColor32($FFFFF5EE); clSienna32 = TColor32($FFA0522D); clSilver32 = TColor32($FFC0C0C0); clSkyblue32 = TColor32($FF87CEEB); clSlateBlue32 = TColor32($FF6A5ACD); clSlateGray32 = TColor32($FF708090); clSlateGrey32 = TColor32($FF708090); clSnow32 = TColor32($FFFFFAFA); clSpringgreen32 = TColor32($FF00FF7F); clSteelblue32 = TColor32($FF4682B4); clTan32 = TColor32($FFD2B48C); clThistle32 = TColor32($FFD8BFD8); clTomato32 = TColor32($FFFF6347); clTurquoise32 = TColor32($FF40E0D0); clViolet32 = TColor32($FFEE82EE); clWheat32 = TColor32($FFF5DEB3); clWhitesmoke32 = TColor32($FFF5F5F5); clYellowgreen32 = TColor32($FF9ACD32); // Some semi-transparent color constants clTrWhite32 = TColor32($7FFFFFFF); clTrGray32 = TColor32($7F7F7F7F); clTrBlack32 = TColor32($7F000000); clTrRed32 = TColor32($7FFF0000); clTrGreen32 = TColor32($7F00FF00); clTrBlue32 = TColor32($7F0000FF); // Color construction and conversion functions function Color32(WinColor: TColor): TColor32; overload; function Color32(R, G, B: Byte; A: Byte = $FF): TColor32; overload; function Color32(Index: Byte; var Palette: TPalette32): TColor32; overload; function Gray32(Intensity: Byte; Alpha: Byte = $FF): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} function WinColor(Color32: TColor32): TColor; function ArrayOfColor32(Colors: array of TColor32): TArrayOfColor32; // Color component access procedure Color32ToRGB(Color32: TColor32; var R, G, B: Byte); procedure Color32ToRGBA(Color32: TColor32; var R, G, B, A: Byte); function Color32Components(R, G, B, A: Boolean): TColor32Components; function RedComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} function GreenComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} function BlueComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} function AlphaComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} function Intensity(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} function InvertColor(Color32: TColor32): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} function SetAlpha(Color32: TColor32; NewAlpha: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} procedure ModifyAlpha(var Color32: TColor32; NewAlpha: Byte); {$IFDEF USEINLINING} inline; {$ENDIF} procedure ScaleAlpha(var Color32: TColor32; Scale: Single); {$IFDEF USEINLINING} inline; {$ENDIF} // Color space conversion function HSLtoRGB(H, S, L: Single): TColor32; overload; procedure RGBtoHSL(RGB: TColor32; out H, S, L : Single); overload; function HSLtoRGB(H, S, L: Integer; A: Integer = $ff): TColor32; overload; procedure RGBtoHSL(RGB: TColor32; out H, S, L: Byte); overload; function HSVtoRGB(H, S, V: Single): TColor32; procedure RGBToHSV(Color: TColor32; out H, S, V: Single); {$IFNDEF PLATFORM_INDEPENDENT} // Palette conversion functions function WinPalette(const P: TPalette32): HPALETTE; {$ENDIF} { A fixed-point type } type // This type has data bits arrangement compatible with Windows.TFixed PFixed = ^TFixed; TFixed = type Integer; {$NODEFINE TFixed} {$NODEFINE PFixedRec} PFixedRec = ^TFixedRec; {$NODEFINE TFixedRec} TFixedRec = packed record case Integer of 0: (Fixed: TFixed); 1: (Frac: Word; Int: SmallInt); end; PFixedArray = ^TFixedArray; TFixedArray = array [0..0] of TFixed; PArrayOfFixed = ^TArrayOfFixed; TArrayOfFixed = array of TFixed; PArrayOfArrayOfFixed = ^TArrayOfArrayOfFixed; TArrayOfArrayOfFixed = array of TArrayOfFixed; // TFloat determines the precision level for certain floating-point operations PFloat = ^TFloat; TFloat = Single; { Other dynamic arrays } type PByteArray = ^TByteArray; TByteArray = array [0..0] of Byte; PArrayOfByte = ^TArrayOfByte; TArrayOfByte = array of Byte; PWordArray = ^TWordArray; TWordArray = array [0..0] of Word; PArrayOfWord = ^TArrayOfWord; TArrayOfWord = array of Word; PIntegerArray = ^TIntegerArray; TIntegerArray = array [0..0] of Integer; PArrayOfInteger = ^TArrayOfInteger; TArrayOfInteger = array of Integer; PArrayOfArrayOfInteger = ^TArrayOfArrayOfInteger; TArrayOfArrayOfInteger = array of TArrayOfInteger; PCardinalArray = ^TCardinalArray; TCardinalArray = array [0..0] of Cardinal; PArrayOfCardinal = ^TArrayOfCardinal; TArrayOfCardinal = array of Cardinal; PArrayOfArrayOfCardinal = ^TArrayOfArrayOfCardinal; TArrayOfArrayOfCardinal = array of TArrayOfCardinal; PSingleArray = ^TSingleArray; TSingleArray = array [0..0] of Single; PArrayOfSingle = ^TArrayOfSingle; TArrayOfSingle = array of Single; PFloatArray = ^TFloatArray; TFloatArray = array [0..0] of TFloat; PArrayOfFloat = ^TArrayOfFloat; TArrayOfFloat = array of TFloat; const // Fixed point math constants FixedOne = $10000; FixedHalf = $7FFF; FixedPI = Round(PI * FixedOne); FixedToFloat = 1 / FixedOne; COne255th = 1 / $FF; function Fixed(S: Single): TFixed; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Fixed(I: Integer): TFixed; overload; {$IFDEF USEINLINING} inline; {$ENDIF} { Points } type {$IFNDEF FPC} {$IFNDEF BCB} PPoint = ^TPoint; TPoint = Windows.TPoint; {$ENDIF} {$ENDIF} PPointArray = ^TPointArray; TPointArray = array [0..0] of TPoint; PArrayOfPoint = ^TArrayOfPoint; TArrayOfPoint = array of TPoint; PArrayOfArrayOfPoint = ^TArrayOfArrayOfPoint; TArrayOfArrayOfPoint = array of TArrayOfPoint; PFloatPoint = ^TFloatPoint; TFloatPoint = record X, Y: TFloat; {$IFDEF SUPPORT_ENHANCED_RECORDS} public {$IFNDEF FPC} {$IFDEF COMPILERXE2_UP} constructor Create(P: TPointF); overload; {$ENDIF} constructor Create(P: TPoint); overload; constructor Create(X, Y: Integer); overload; constructor Create(X, Y: Single); overload; {$ENDIF} // operator overloads class operator Equal(const Lhs, Rhs: TFloatPoint): Boolean; class operator NotEqual(const Lhs, Rhs: TFloatPoint): Boolean; class operator Add(const Lhs, Rhs: TFloatPoint): TFloatPoint; class operator Subtract(const Lhs, Rhs: TFloatPoint): TFloatPoint; {$IFDEF COMPILERXE2_UP} class operator Explicit(A: TPointF): TFloatPoint; class operator Implicit(A: TPointF): TFloatPoint; {$ENDIF} class function Zero: TFloatPoint; inline; static; {$ENDIF} end; PFloatPointArray = ^TFloatPointArray; TFloatPointArray = array [0..0] of TFloatPoint; PArrayOfFloatPoint = ^TArrayOfFloatPoint; TArrayOfFloatPoint = array of TFloatPoint; PArrayOfArrayOfFloatPoint = ^TArrayOfArrayOfFloatPoint; TArrayOfArrayOfFloatPoint = array of TArrayOfFloatPoint; PFixedPoint = ^TFixedPoint; TFixedPoint = record X, Y: TFixed; {$IFDEF SUPPORT_ENHANCED_RECORDS} public {$IFNDEF FPC} {$IFDEF COMPILERXE2_UP} constructor Create(P: TPointF); overload; {$ENDIF} constructor Create(P: TFloatPoint); overload; constructor Create(X, Y: TFixed); overload; constructor Create(X, Y: Integer); overload; constructor Create(X, Y: TFloat); overload; {$ENDIF} // operator overloads class operator Equal(const Lhs, Rhs: TFixedPoint): Boolean; class operator NotEqual(const Lhs, Rhs: TFixedPoint): Boolean; class operator Add(const Lhs, Rhs: TFixedPoint): TFixedPoint; class operator Subtract(const Lhs, Rhs: TFixedPoint): TFixedPoint; class function Zero: TFixedPoint; inline; static; {$ENDIF} end; PFixedPointArray = ^TFixedPointArray; TFixedPointArray = array [0..0] of TFixedPoint; PArrayOfFixedPoint = ^TArrayOfFixedPoint; TArrayOfFixedPoint = array of TFixedPoint; PArrayOfArrayOfFixedPoint = ^TArrayOfArrayOfFixedPoint; TArrayOfArrayOfFixedPoint = array of TArrayOfFixedPoint; // construction and conversion of point types function Point(X, Y: Integer): TPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Point(const FP: TFloatPoint): TPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Point(const FXP: TFixedPoint): TPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FloatPoint(X, Y: Single): TFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FloatPoint(const P: TPoint): TFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FloatPoint(const FXP: TFixedPoint): TFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FixedPoint(X, Y: Integer): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FixedPoint(X, Y: Single): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FixedPoint(const P: TPoint): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FixedPoint(const FP: TFloatPoint): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} { Rectangles } type {$IFNDEF FPC} PRect = Windows.PRect; TRect = Windows.TRect; {$ENDIF} PFloatRect = ^TFloatRect; {$NODEFINE TFloatRect} (*$HPPEMIT '#include <boost/strong_typedef.hpp>'*) (*$HPPEMIT 'namespace Gr32 {'*) (*$HPPEMIT 'BOOST_STRONG_TYPEDEF(int, TFixed)'*) (*$HPPEMIT 'struct TFloatRect { float Left, Top, Right, Bottom; }; typedef struct TFloatRect TFloatRect;'*) (*$HPPEMIT 'struct TFixedRect { TFixed Left, Top, Right, Bottom; }; typedef struct TFixedRect TFixedRect;'*) (*$HPPEMIT '} // namespace Gr32 '*) TFloatRect = packed record case Integer of 0: (Left, Top, Right, Bottom: TFloat); 1: (TopLeft, BottomRight: TFloatPoint); end; {$NODEFINE PFixedRect} PFixedRect = ^TFixedRect; {$NODEFINE TFixedRect} TFixedRect = packed record case Integer of 0: (Left, Top, Right, Bottom: TFixed); 1: (TopLeft, BottomRight: TFixedPoint); end; TRectRounding = (rrClosest, rrOutside, rrInside); // Rectangle construction/conversion functions function MakeRect(const L, T, R, B: Integer): TRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function MakeRect(const FR: TFloatRect; Rounding: TRectRounding = rrClosest): TRect; overload; function MakeRect(const FXR: TFixedRect; Rounding: TRectRounding = rrClosest): TRect; overload; function FixedRect(const L, T, R, B: TFixed): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FixedRect(const TopLeft, BottomRight: TFixedPoint): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FixedRect(const ARect: TRect): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FixedRect(const FR: TFloatRect): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FloatRect(const L, T, R, B: TFloat): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FloatRect(const TopLeft, BottomRight: TFloatPoint): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FloatRect(const ARect: TRect): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function FloatRect(const FXR: TFixedRect): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} // Some basic operations over rectangles function IntersectRect(out Dst: TRect; const R1, R2: TRect): Boolean; overload; function IntersectRect(out Dst: TFloatRect; const FR1, FR2: TFloatRect): Boolean; overload; function UnionRect(out Rect: TRect; const R1, R2: TRect): Boolean; overload; function UnionRect(out Rect: TFloatRect; const R1, R2: TFloatRect): Boolean; overload; function EqualRect(const R1, R2: TRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function EqualRect(const R1, R2: TFloatRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure InflateRect(var R: TRect; Dx, Dy: Integer); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure InflateRect(var FR: TFloatRect; Dx, Dy: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure OffsetRect(var R: TRect; Dx, Dy: Integer); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure OffsetRect(var FR: TFloatRect; Dx, Dy: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} function IsRectEmpty(const R: TRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function IsRectEmpty(const FR: TFloatRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function PtInRect(const R: TRect; const P: TPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function PtInRect(const R: TFloatRect; const P: TPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function PtInRect(const R: TRect; const P: TFloatPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function PtInRect(const R: TFloatRect; const P: TFloatPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function EqualRectSize(const R1, R2: TRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function EqualRectSize(const R1, R2: TFloatRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} type { TBitmap32 draw mode } TDrawMode = (dmOpaque, dmBlend, dmCustom, dmTransparent); TCombineMode = (cmBlend, cmMerge); TWrapMode = (wmClamp, wmRepeat, wmMirror); TWrapProc = function(Value, Max: Integer): Integer; TWrapProcEx = function(Value, Min, Max: Integer): Integer; {$IFDEF DEPRECATEDMODE} { Stretch filters } TStretchFilter = (sfNearest, sfDraft, sfLinear, sfCosine, sfSpline, sfLanczos, sfMitchell); {$ENDIF} { Gamma bias for line/pixel antialiasing } var GAMMA_TABLE: array [Byte] of Byte; procedure SetGamma(Gamma: Single = 1.6); type { TPlainInterfacedPersistent } { TPlainInterfacedPersistent provides simple interface support with optional reference-counting operation. } TPlainInterfacedPersistent = class(TPersistent, IInterface) private FRefCounted: Boolean; FRefCount: Integer; protected { IInterface } {$IFDEF FPC_HAS_CONSTREF} function QueryInterface(constref iid: TGuid; out obj): HResult; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; {$ELSE} function QueryInterface(const iid: TGuid; out obj): HResult; stdcall; function _AddRef: LongInt; stdcall; function _Release: LongInt; stdcall; {$ENDIF} property RefCounted: Boolean read FRefCounted write FRefCounted; public procedure AfterConstruction; override; procedure BeforeDestruction; override; class function NewInstance: TObject; override; property RefCount: Integer read FRefCount; end; { TNotifiablePersistent } { TNotifiablePersistent provides a change notification mechanism } TNotifiablePersistent = class(TPlainInterfacedPersistent) private FUpdateCount: Integer; FOnChange: TNotifyEvent; protected property UpdateCount: Integer read FUpdateCount; public procedure Changed; virtual; procedure BeginUpdate; virtual; procedure EndUpdate; virtual; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; { TThreadPersistent } { TThreadPersistent is an ancestor for TBitmap32 object. In addition to TPersistent methods, it provides thread-safe locking and change notification } TThreadPersistent = class(TNotifiablePersistent) private FLockCount: Integer; protected {$IFDEF FPC} FLock: TCriticalSection; {$ELSE} FLock: TRTLCriticalSection; {$ENDIF} property LockCount: Integer read FLockCount; public constructor Create; virtual; destructor Destroy; override; procedure Lock; procedure Unlock; end; { TCustomMap } { An ancestor for bitmaps and similar 2D distributions wich have width and height properties } TCustomMap = class(TThreadPersistent) protected FHeight: Integer; FWidth: Integer; FOnResize: TNotifyEvent; procedure SetHeight(NewHeight: Integer); virtual; procedure SetWidth(NewWidth: Integer); virtual; procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); virtual; public constructor Create(Width, Height: Integer); reintroduce; overload; procedure Delete; virtual; function Empty: Boolean; virtual; procedure Resized; virtual; function SetSizeFrom(Source: TPersistent): Boolean; function SetSize(NewWidth, NewHeight: Integer): Boolean; virtual; property Height: Integer read FHeight write SetHeight; property Width: Integer read FWidth write SetWidth; property OnResize: TNotifyEvent read FOnResize write FOnResize; end; { TBitmap32 } { This is the core of Graphics32 unit. The TBitmap32 class is responsible for storage of a bitmap, as well as for drawing in it. The OnCombine event is fired only when DrawMode is set to dmCustom and two bitmaps are blended together. Unlike most normal events, it does not contain "Sender" parameter and is not called through some virtual method. This (a little bit non-standard) approach allows for faster operation. } const // common cases AREAINFO_RECT = $80000000; AREAINFO_LINE = $40000000; // 24 bits for line width in pixels... AREAINFO_ELLIPSE = $20000000; AREAINFO_ABSOLUTE = $10000000; AREAINFO_MASK = $FF000000; type TPixelCombineEvent = procedure(F: TColor32; var B: TColor32; M: TColor32) of object; TAreaChangedEvent = procedure(Sender: TObject; const Area: TRect; const Info: Cardinal) of object; TCustomResampler = class; TCustomBackend = class; TCustomBackendClass = class of TCustomBackend; TCustomBitmap32 = class(TCustomMap) private FBackend: TCustomBackend; FBits: PColor32Array; FClipRect: TRect; FFixedClipRect: TFixedRect; F256ClipRect: TRect; FClipping: Boolean; FDrawMode: TDrawMode; FCombineMode: TCombineMode; FWrapMode: TWrapMode; FMasterAlpha: Cardinal; FOuterColor: TColor32; FPenColor: TColor32; FStippleCounter: Single; FStipplePattern: TArrayOfColor32; FStippleStep: Single; {$IFDEF DEPRECATEDMODE} FStretchFilter: TStretchFilter; {$ENDIF} FOnPixelCombine: TPixelCombineEvent; FOnAreaChanged: TAreaChangedEvent; FOldOnAreaChanged: TAreaChangedEvent; FMeasuringMode: Boolean; FResampler: TCustomResampler; procedure BackendChangedHandler(Sender: TObject); virtual; procedure BackendChangingHandler(Sender: TObject); virtual; {$IFDEF BITS_GETTER} function GetBits: PColor32Array; {$IFDEF USEINLINING} inline; {$ENDIF} {$ENDIF} function GetPixelPtr(X, Y: Integer): PColor32; function GetScanLine(Y: Integer): PColor32Array; procedure SetCombineMode(const Value: TCombineMode); procedure SetDrawMode(Value: TDrawMode); procedure SetWrapMode(Value: TWrapMode); procedure SetMasterAlpha(Value: Cardinal); {$IFDEF DEPRECATEDMODE} procedure SetStretchFilter(Value: TStretchFilter); {$ENDIF} procedure SetClipRect(const Value: TRect); procedure SetResampler(Resampler: TCustomResampler); function GetResamplerClassName: string; procedure SetResamplerClassName(const Value: string); protected WrapProcHorz: TWrapProcEx; WrapProcVert: TWrapProcEx; BlendProc: Pointer; RasterX, RasterY: Integer; RasterXF, RasterYF: TFixed; procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; procedure CopyMapTo(Dst: TCustomBitmap32); virtual; procedure CopyPropertiesTo(Dst: TCustomBitmap32); virtual; procedure AssignTo(Dst: TPersistent); override; function Equal(B: TCustomBitmap32): Boolean; procedure SET_T256(X, Y: Integer; C: TColor32); procedure SET_TS256(X, Y: Integer; C: TColor32); function GET_T256(X, Y: Integer): TColor32; function GET_TS256(X, Y: Integer): TColor32; procedure ReadData(Stream: TStream); virtual; procedure WriteData(Stream: TStream); virtual; procedure DefineProperties(Filer: TFiler); override; procedure InitializeBackend(Backend: TCustomBackendClass); virtual; procedure FinalizeBackend; virtual; procedure SetBackend(const Backend: TCustomBackend); virtual; {$IFDEF FPC_HAS_CONSTREF} function QueryInterface(constref iid: TGuid; out obj): HResult; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; {$ELSE} function QueryInterface(const iid: TGuid; out obj): HResult; stdcall; {$ENDIF} function GetPixel(X, Y: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} function GetPixelS(X, Y: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} function GetPixelW(X, Y: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} function GetPixelF(X, Y: Single): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} function GetPixelFS(X, Y: Single): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} function GetPixelFW(X, Y: Single): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} function GetPixelX(X, Y: TFixed): TColor32; function GetPixelXS(X, Y: TFixed): TColor32; function GetPixelXW(X, Y: TFixed): TColor32; function GetPixelFR(X, Y: Single): TColor32; function GetPixelXR(X, Y: TFixed): TColor32; function GetPixelB(X, Y: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} procedure SetPixel(X, Y: Integer; Value: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF} procedure SetPixelS(X, Y: Integer; Value: TColor32); procedure SetPixelW(X, Y: Integer; Value: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF} procedure SetPixelF(X, Y: Single; Value: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF} procedure SetPixelFS(X, Y: Single; Value: TColor32); procedure SetPixelFW(X, Y: Single; Value: TColor32); procedure SetPixelX(X, Y: TFixed; Value: TColor32); procedure SetPixelXS(X, Y: TFixed; Value: TColor32); procedure SetPixelXW(X, Y: TFixed; Value: TColor32); public constructor Create(Backend: TCustomBackendClass); reintroduce; overload; virtual; constructor Create; reintroduce; overload; virtual; destructor Destroy; override; class function GetPlatformBackendClass: TCustomBackendClass; virtual; procedure Assign(Source: TPersistent); override; function BoundsRect: TRect; function Empty: Boolean; override; procedure Clear; overload; procedure Clear(FillColor: TColor32); overload; procedure Delete; override; procedure BeginMeasuring(const Callback: TAreaChangedEvent); procedure EndMeasuring; function ReleaseBackend: TCustomBackend; procedure PropertyChanged; virtual; procedure Changed; overload; override; procedure Changed(const Area: TRect; const Info: Cardinal = AREAINFO_RECT); reintroduce; overload; virtual; procedure LoadFromStream(Stream: TStream); virtual; procedure SaveToStream(Stream: TStream; SaveTopDown: Boolean = False); virtual; procedure LoadFromFile(const FileName: string); virtual; procedure SaveToFile(const FileName: string; SaveTopDown: Boolean = False); virtual; procedure LoadFromResourceID(Instance: THandle; ResID: Integer); procedure LoadFromResourceName(Instance: THandle; const ResName: string); procedure ResetAlpha; overload; procedure ResetAlpha(const AlphaValue: Byte); overload; procedure Draw(DstX, DstY: Integer; Src: TCustomBitmap32); overload; procedure Draw(DstX, DstY: Integer; const SrcRect: TRect; Src: TCustomBitmap32); overload; procedure Draw(const DstRect, SrcRect: TRect; Src: TCustomBitmap32); overload; procedure SetPixelT(X, Y: Integer; Value: TColor32); overload; procedure SetPixelT(var Ptr: PColor32; Value: TColor32); overload; procedure SetPixelTS(X, Y: Integer; Value: TColor32); procedure DrawTo(Dst: TCustomBitmap32); overload; procedure DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer); overload; procedure DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer; const SrcRect: TRect); overload; procedure DrawTo(Dst: TCustomBitmap32; const DstRect: TRect); overload; procedure DrawTo(Dst: TCustomBitmap32; const DstRect, SrcRect: TRect); overload; procedure SetStipple(NewStipple: TArrayOfColor32); overload; procedure SetStipple(NewStipple: array of TColor32); overload; procedure AdvanceStippleCounter(LengthPixels: Single); function GetStippleColor: TColor32; procedure HorzLine(X1, Y, X2: Integer; Value: TColor32); procedure HorzLineS(X1, Y, X2: Integer; Value: TColor32); procedure HorzLineT(X1, Y, X2: Integer; Value: TColor32); procedure HorzLineTS(X1, Y, X2: Integer; Value: TColor32); procedure HorzLineTSP(X1, Y, X2: Integer); procedure HorzLineX(X1, Y, X2: TFixed; Value: TColor32); procedure HorzLineXS(X1, Y, X2: TFixed; Value: TColor32); procedure VertLine(X, Y1, Y2: Integer; Value: TColor32); procedure VertLineS(X, Y1, Y2: Integer; Value: TColor32); procedure VertLineT(X, Y1, Y2: Integer; Value: TColor32); procedure VertLineTS(X, Y1, Y2: Integer; Value: TColor32); procedure VertLineTSP(X, Y1, Y2: Integer); procedure VertLineX(X, Y1, Y2: TFixed; Value: TColor32); procedure VertLineXS(X, Y1, Y2: TFixed; Value: TColor32); procedure Line(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False); procedure LineS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False); procedure LineT(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False); procedure LineTS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False); procedure LineA(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False); procedure LineAS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False); procedure LineX(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean = False); overload; procedure LineF(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean = False); overload; procedure LineXS(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean = False); overload; procedure LineFS(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean = False); overload; procedure LineXP(X1, Y1, X2, Y2: TFixed; L: Boolean = False); overload; procedure LineFP(X1, Y1, X2, Y2: Single; L: Boolean = False); overload; procedure LineXSP(X1, Y1, X2, Y2: TFixed; L: Boolean = False); overload; procedure LineFSP(X1, Y1, X2, Y2: Single; L: Boolean = False); overload; property PenColor: TColor32 read FPenColor write FPenColor; procedure MoveTo(X, Y: Integer); procedure LineToS(X, Y: Integer); procedure LineToTS(X, Y: Integer); procedure LineToAS(X, Y: Integer); procedure MoveToX(X, Y: TFixed); procedure MoveToF(X, Y: Single); procedure LineToXS(X, Y: TFixed); procedure LineToFS(X, Y: Single); procedure LineToXSP(X, Y: TFixed); procedure LineToFSP(X, Y: Single); procedure FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32); procedure FillRectS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload; procedure FillRectT(X1, Y1, X2, Y2: Integer; Value: TColor32); procedure FillRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload; procedure FillRectS(const ARect: TRect; Value: TColor32); overload; procedure FillRectTS(const ARect: TRect; Value: TColor32); overload; procedure FrameRectS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload; procedure FrameRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload; procedure FrameRectTSP(X1, Y1, X2, Y2: Integer); procedure FrameRectS(const ARect: TRect; Value: TColor32); overload; procedure FrameRectTS(const ARect: TRect; Value: TColor32); overload; procedure RaiseRectTS(X1, Y1, X2, Y2: Integer; Contrast: Integer); overload; procedure RaiseRectTS(const ARect: TRect; Contrast: Integer); overload; procedure Roll(Dx, Dy: Integer; FillBack: Boolean; FillColor: TColor32); procedure FlipHorz(Dst: TCustomBitmap32 = nil); procedure FlipVert(Dst: TCustomBitmap32 = nil); procedure Rotate90(Dst: TCustomBitmap32 = nil); procedure Rotate180(Dst: TCustomBitmap32 = nil); procedure Rotate270(Dst: TCustomBitmap32 = nil); procedure ResetClipRect; property Pixel[X, Y: Integer]: TColor32 read GetPixel write SetPixel; default; property PixelS[X, Y: Integer]: TColor32 read GetPixelS write SetPixelS; property PixelW[X, Y: Integer]: TColor32 read GetPixelW write SetPixelW; property PixelX[X, Y: TFixed]: TColor32 read GetPixelX write SetPixelX; property PixelXS[X, Y: TFixed]: TColor32 read GetPixelXS write SetPixelXS; property PixelXW[X, Y: TFixed]: TColor32 read GetPixelXW write SetPixelXW; property PixelF[X, Y: Single]: TColor32 read GetPixelF write SetPixelF; property PixelFS[X, Y: Single]: TColor32 read GetPixelFS write SetPixelFS; property PixelFW[X, Y: Single]: TColor32 read GetPixelFW write SetPixelFW; property PixelFR[X, Y: Single]: TColor32 read GetPixelFR; property PixelXR[X, Y: TFixed]: TColor32 read GetPixelXR; property Backend: TCustomBackend read FBackend write SetBackend; {$IFDEF BITS_GETTER} property Bits: PColor32Array read GetBits; {$ELSE} property Bits: PColor32Array read FBits; {$ENDIF} property ClipRect: TRect read FClipRect write SetClipRect; property Clipping: Boolean read FClipping; property PixelPtr[X, Y: Integer]: PColor32 read GetPixelPtr; property ScanLine[Y: Integer]: PColor32Array read GetScanLine; property StippleCounter: Single read FStippleCounter write FStippleCounter; property StippleStep: Single read FStippleStep write FStippleStep; property MeasuringMode: Boolean read FMeasuringMode; published property DrawMode: TDrawMode read FDrawMode write SetDrawMode default dmOpaque; property CombineMode: TCombineMode read FCombineMode write SetCombineMode default cmBlend; property WrapMode: TWrapMode read FWrapMode write SetWrapMode default wmClamp; property MasterAlpha: Cardinal read FMasterAlpha write SetMasterAlpha default $FF; property OuterColor: TColor32 read FOuterColor write FOuterColor default 0; {$IFDEF DEPRECATEDMODE} property StretchFilter: TStretchFilter read FStretchFilter write SetStretchFilter default sfNearest; {$ENDIF} property ResamplerClassName: string read GetResamplerClassName write SetResamplerClassName; property Resampler: TCustomResampler read FResampler write SetResampler; property OnChange; property OnPixelCombine: TPixelCombineEvent read FOnPixelCombine write FOnPixelCombine; property OnAreaChanged: TAreaChangedEvent read FOnAreaChanged write FOnAreaChanged; property OnResize; end; TBitmap32 = class(TCustomBitmap32) private FOnHandleChanged: TNotifyEvent; procedure BackendChangedHandler(Sender: TObject); override; procedure BackendChangingHandler(Sender: TObject); override; procedure FontChanged(Sender: TObject); procedure CanvasChanged(Sender: TObject); function GetCanvas: TCanvas; {$IFDEF USEINLINING} inline; {$ENDIF} function GetBitmapInfo: TBitmapInfo; {$IFDEF USEINLINING} inline; {$ENDIF} function GetHandle: HBITMAP; {$IFDEF USEINLINING} inline; {$ENDIF} function GetHDC: HDC; {$IFDEF USEINLINING} inline; {$ENDIF} function GetFont: TFont; procedure SetFont(Value: TFont); protected procedure FinalizeBackend; override; procedure SetBackend(const Backend: TCustomBackend); override; procedure HandleChanged; virtual; procedure CopyPropertiesTo(Dst: TCustomBitmap32); override; public class function GetPlatformBackendClass: TCustomBackendClass; override; {$IFDEF BCB} procedure Draw(const DstRect, SrcRect: TRect; hSrc: Cardinal); overload; {$ELSE} procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload; {$ENDIF} {$IFDEF BCB} procedure DrawTo(hDst: Cardinal; DstX, DstY: Integer); overload; procedure DrawTo(hDst: Cardinal; const DstRect, SrcRect: TRect); overload; procedure TileTo(hDst: Cardinal; const DstRect, SrcRect: TRect); {$ELSE} procedure DrawTo(hDst: HDC; DstX: Integer = 0; DstY: Integer = 0); overload; procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; procedure TileTo(hDst: HDC; const DstRect, SrcRect: TRect); {$ENDIF} procedure UpdateFont; procedure Textout(X, Y: Integer; const Text: string); overload; procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload; procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload; function TextExtent(const Text: string): TSize; function TextHeight(const Text: string): Integer; function TextWidth(const Text: string): Integer; procedure RenderText(X, Y: Integer; const Text: string; AALevel: Integer; Color: TColor32); procedure TextoutW(X, Y: Integer; const Text: Widestring); overload; procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload; procedure TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload; function TextExtentW(const Text: Widestring): TSize; function TextHeightW(const Text: Widestring): Integer; function TextWidthW(const Text: Widestring): Integer; procedure RenderTextW(X, Y: Integer; const Text: Widestring; AALevel: Integer; Color: TColor32); property Canvas: TCanvas read GetCanvas; function CanvasAllocated: Boolean; procedure DeleteCanvas; property Font: TFont read GetFont write SetFont; property BitmapHandle: HBITMAP read GetHandle; property BitmapInfo: TBitmapInfo read GetBitmapInfo; property Handle: HDC read GetHDC; published property OnHandleChanged: TNotifyEvent read FOnHandleChanged write FOnHandleChanged; end; { TCustomBackend } { This class functions as backend for the TBitmap32 class. It manages and provides the backing buffer as well as OS or graphics subsystem specific features.} TCustomBackend = class(TThreadPersistent) protected FBits: PColor32Array; FOwner: TCustomBitmap32; FOnChanging: TNotifyEvent; procedure Changing; virtual; {$IFDEF BITS_GETTER} function GetBits: PColor32Array; virtual; {$ENDIF} procedure InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); virtual; procedure FinalizeSurface; virtual; public constructor Create; overload; override; constructor Create(Owner: TCustomBitmap32); reintroduce; overload; virtual; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Clear; virtual; function Empty: Boolean; virtual; procedure ChangeSize(out Width, Height: Integer; NewWidth, NewHeight: Integer; ClearBuffer: Boolean = True); virtual; {$IFDEF BITS_GETTER} property Bits: PColor32Array read GetBits; {$ELSE} property Bits: PColor32Array read FBits; {$ENDIF} property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; end; { TCustomSampler } TCustomSampler = class(TNotifiablePersistent) public function GetSampleInt(X, Y: Integer): TColor32; virtual; function GetSampleFixed(X, Y: TFixed): TColor32; virtual; function GetSampleFloat(X, Y: TFloat): TColor32; virtual; procedure PrepareSampling; virtual; procedure FinalizeSampling; virtual; function HasBounds: Boolean; virtual; function GetSampleBounds: TFloatRect; virtual; end; TPixelAccessMode = (pamUnsafe, pamSafe, pamWrap, pamTransparentEdge); { TCustomResampler } { Base class for TCustomBitmap32 specific resamplers. } TCustomResampler = class(TCustomSampler) private FBitmap: TCustomBitmap32; FClipRect: TRect; FPixelAccessMode: TPixelAccessMode; procedure SetPixelAccessMode(const Value: TPixelAccessMode); protected function GetWidth: TFloat; virtual; procedure Resample( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); virtual; abstract; procedure AssignTo(Dst: TPersistent); override; property ClipRect: TRect read FClipRect; public constructor Create; overload; virtual; constructor Create(ABitmap: TCustomBitmap32); overload; virtual; procedure Changed; override; procedure PrepareSampling; override; function HasBounds: Boolean; override; function GetSampleBounds: TFloatRect; override; property Bitmap: TCustomBitmap32 read FBitmap write FBitmap; property Width: TFloat read GetWidth; published property PixelAccessMode: TPixelAccessMode read FPixelAccessMode write SetPixelAccessMode default pamSafe; end; TCustomResamplerClass = class of TCustomResampler; var StockBitmap: TBitmap; resourcestring RCStrUnmatchedReferenceCounting = 'Unmatched reference counting.'; RCStrCannotSetSize = 'Can''t set size from ''%s'''; RCStrInpropriateBackend = 'Inappropriate Backend'; implementation uses Math, GR32_Blend, GR32_LowLevel, GR32_Math, GR32_Resamplers, GR32_Containers, GR32_Backends, GR32_Backends_Generic, {$IFDEF FPC} Clipbrd, {$IFDEF LCLWin32} GR32_Backends_LCL_Win, {$ENDIF} {$IF defined(LCLGtk) or defined(LCLGtk2)} GR32_Backends_LCL_Gtk, {$IFEND} {$IFDEF LCLCarbon} GR32_Backends_LCL_Carbon, {$ENDIF} {$IFDEF LCLCustomDrawn} GR32_Backends_LCL_CustomDrawn, {$ENDIF} {$ELSE} Clipbrd, GR32_Backends_VCL, {$ENDIF} GR32_VectorUtils; type { We can not use the Win32 defined record here since we are cross-platform. } TBmpHeader = packed record bfType: Word; bfSize: LongInt; bfReserved: LongInt; bfOffBits: LongInt; biSize: LongInt; biWidth: LongInt; biHeight: LongInt; biPlanes: Word; biBitCount: Word; biCompression: LongInt; biSizeImage: LongInt; biXPelsPerMeter: LongInt; biYPelsPerMeter: LongInt; biClrUsed: LongInt; biClrImportant: LongInt; end; TGraphicAccess = class(TGraphic); const ZERO_RECT: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0); { Color construction and conversion functions } {$IFDEF PUREPASCAL} {$DEFINE USENATIVECODE} {$ENDIF} {$IFDEF TARGET_X64} {$DEFINE USENATIVECODE} {$ENDIF} function Color32(WinColor: TColor): TColor32; overload; {$IFDEF WIN_COLOR_FIX} var I: Longword; {$ENDIF} begin if WinColor < 0 then WinColor := GetSysColor(WinColor and $000000FF); {$IFDEF WIN_COLOR_FIX} Result := $FF000000; I := (WinColor and $00FF0000) shr 16; if I <> 0 then Result := Result or TColor32(Integer(I) - 1); I := WinColor and $0000FF00; if I <> 0 then Result := Result or TColor32(Integer(I) - $00000100); I := WinColor and $000000FF; if I <> 0 then Result := Result or TColor32(Integer(I) - 1) shl 16; {$ELSE} {$IFDEF USENATIVECODE} Result := $FF shl 24 + (WinColor and $FF0000) shr 16 + (WinColor and $FF00) + (WinColor and $FF) shl 16; {$ELSE} asm MOV EAX,WinColor BSWAP EAX MOV AL,$FF ROR EAX,8 MOV Result,EAX end; {$ENDIF} {$ENDIF} end; function Color32(R, G, B: Byte; A: Byte = $FF): TColor32; overload; {$IFDEF USENATIVECODE} begin Result := (A shl 24) or (R shl 16) or (G shl 8) or B; {$ELSE} asm MOV AH, A SHL EAX, 16 MOV AH, DL MOV AL, CL {$ENDIF} end; function Color32(Index: Byte; var Palette: TPalette32): TColor32; overload; begin Result := Palette[Index]; end; function Gray32(Intensity: Byte; Alpha: Byte = $FF): TColor32; begin Result := TColor32(Alpha) shl 24 + TColor32(Intensity) shl 16 + TColor32(Intensity) shl 8 + TColor32(Intensity); end; function WinColor(Color32: TColor32): TColor; {$IFDEF PUREPASCAL} begin Result := ((Color32 and $00FF0000) shr 16) or (Color32 and $0000FF00) or ((Color32 and $000000FF) shl 16); {$ELSE} asm {$IFDEF TARGET_x64} MOV EAX, ECX {$ENDIF} // the alpha channel byte is set to zero! ROL EAX, 8 // ABGR -> RGBA XOR AL, AL // BGRA -> BGR0 BSWAP EAX // BGR0 -> 0RGB {$ENDIF} end; function ArrayOfColor32(Colors: array of TColor32): TArrayOfColor32; var L: Integer; begin // build a dynamic color array from specified colors L := High(Colors) + 1; SetLength(Result, L); MoveLongword(Colors[0], Result[0], L); end; procedure Color32ToRGB(Color32: TColor32; var R, G, B: Byte); begin R := (Color32 and $00FF0000) shr 16; G := (Color32 and $0000FF00) shr 8; B := Color32 and $000000FF; end; procedure Color32ToRGBA(Color32: TColor32; var R, G, B, A: Byte); begin A := Color32 shr 24; R := (Color32 and $00FF0000) shr 16; G := (Color32 and $0000FF00) shr 8; B := Color32 and $000000FF; end; function Color32Components(R, G, B, A: Boolean): TColor32Components; const ccR : array[Boolean] of TColor32Components = ([], [ccRed]); ccG : array[Boolean] of TColor32Components = ([], [ccGreen]); ccB : array[Boolean] of TColor32Components = ([], [ccBlue]); ccA : array[Boolean] of TColor32Components = ([], [ccAlpha]); begin Result := ccR[R] + ccG[G] + ccB[B] + ccA[A]; end; function RedComponent(Color32: TColor32): Integer; begin Result := (Color32 and $00FF0000) shr 16; end; function GreenComponent(Color32: TColor32): Integer; begin Result := (Color32 and $0000FF00) shr 8; end; function BlueComponent(Color32: TColor32): Integer; begin Result := Color32 and $000000FF; end; function AlphaComponent(Color32: TColor32): Integer; begin Result := Color32 shr 24; end; function Intensity(Color32: TColor32): Integer; begin // (R * 61 + G * 174 + B * 21) / 256 Result := ( (Color32 and $00FF0000) shr 16 * 61 + (Color32 and $0000FF00) shr 8 * 174 + (Color32 and $000000FF) * 21 ) shr 8; end; function InvertColor(Color32: TColor32): TColor32; begin TColor32Entry(Result).R := $FF - TColor32Entry(Color32).R; TColor32Entry(Result).G := $FF - TColor32Entry(Color32).G; TColor32Entry(Result).B := $FF - TColor32Entry(Color32).B; TColor32Entry(Result).A := TColor32Entry(Color32).A; end; function SetAlpha(Color32: TColor32; NewAlpha: Integer): TColor32; begin if NewAlpha < 0 then NewAlpha := 0 else if NewAlpha > $FF then NewAlpha := $FF; Result := (Color32 and $00FFFFFF) or (TColor32(NewAlpha) shl 24); end; procedure ModifyAlpha(var Color32: TColor32; NewAlpha: Byte); begin TColor32Entry(Color32).A := NewAlpha; end; procedure ScaleAlpha(var Color32: TColor32; Scale: Single); begin TColor32Entry(Color32).A := Round(Scale * TColor32Entry(Color32).A); end; { Color space conversions } function HSLtoRGB(H, S, L: Single): TColor32; const OneOverThree = 1 / 3; var M1, M2: Single; function HueToColor(Hue: Single): Byte; var V: Double; begin Hue := Hue - Floor(Hue); if 6 * Hue < 1 then V := M1 + (M2 - M1) * Hue * 6 else if 2 * Hue < 1 then V := M2 else if 3 * Hue < 2 then V := M1 + (M2 - M1) * (2 * OneOverThree - Hue) * 6 else V := M1; Result := Round($FF * V); end; begin if S = 0 then begin Result := Gray32(Round($FF * L)); Exit; end; if L <= 0.5 then M2 := L * (1 + S) else M2 := L + S - L * S; M1 := 2 * L - M2; Result := Color32( HueToColor(H + OneOverThree), HueToColor(H), HueToColor(H - OneOverThree)); end; procedure RGBtoHSL(RGB: TColor32; out H, S, L : Single); const // reciprocal mul. opt. R6 = 1 / 6; var R, G, B, D, Cmax, Cmin: Single; begin R := RedComponent(RGB) * COne255th; G := GreenComponent(RGB) * COne255th; B := BlueComponent(RGB) * COne255th; Cmax := Max(R, Max(G, B)); Cmin := Min(R, Min(G, B)); L := (Cmax + Cmin) * 0.5; if Cmax = Cmin then begin H := 0; S := 0 end else begin D := Cmax - Cmin; if L < 0.5 then S := D / (Cmax + Cmin) else S := D / (2 - Cmax - Cmin); if R = Cmax then H := (G - B) / D else if G = Cmax then H := 2 + (B - R) / D else H := 4 + (R - G) / D; H := H * R6; if H < 0 then H := H + 1 end; end; function HSLtoRGB(H, S, L, A: Integer): TColor32; var V, M, M1, M2, VSF: Integer; begin if L <= $7F then V := L * (256 + S) shr 8 else V := L + S - Integer(Div255(L * S)); if V <= 0 then Result := $FF000000 else begin M := L * 2 - V; H := H * 6; VSF := (V - M) * (H and $FF) shr 8; M1 := M + VSF; M2 := V - VSF; case H shr 8 of 0: Result := Color32(V, M1, M, A); 1: Result := Color32(M2, V, M, A); 2: Result := Color32(M, V, M1, A); 3: Result := Color32(M, M2, V, A); 4: Result := Color32(M1, M, V, A); 5: Result := Color32(V, M, M2, A); else Result := 0; end; end; end; procedure RGBtoHSL(RGB: TColor32; out H, S, L: Byte); var R, G, B, D, Cmax, Cmin, HL: Integer; begin R := (RGB shr 16) and $ff; G := (RGB shr 8) and $ff; B := RGB and $ff; Cmax := Max(R, G, B); Cmin := Min(R, G, B); L := (Cmax + Cmin) shr 1; if Cmax = Cmin then begin H := 0; S := 0 end else begin D := (Cmax - Cmin) * $FF; if L <= $7F then S := D div (Cmax + Cmin) else S := D div ($FF * 2 - Cmax - Cmin); D := D * 6; if R = Cmax then HL := (G - B) * $FF * $FF div D else if G = Cmax then HL := $FF * 2 div 6 + (B - R) * $FF * $FF div D else HL := $FF * 4 div 6 + (R - G) * $FF * $FF div D; if HL < 0 then HL := HL + $FF * 2; H := HL; end; end; function HSVtoRGB(H, S, V: Single): TColor32; var Tmp: TFloat; Sel, Q, P: Integer; begin V := 255 * V; if S = 0 then begin Result := Gray32(Trunc(V)); Exit; end; H := H - Floor(H); Tmp := 6 * H - Floor(6 * H); Sel := Trunc(6 * H); if (Sel mod 2) = 0 then Tmp := 1 - Tmp; Q := Trunc(V * (1 - S)); P := Trunc(V * (1 - S * Tmp)); case Sel of 0: Result := Color32(Trunc(V), P, Q); 1: Result := Color32(P, Trunc(V), Q); 2: Result := Color32(Q, Trunc(V), P); 3: Result := Color32(Q, P, Trunc(V)); 4: Result := Color32(P, Q, Trunc(V)); 5: Result := Color32(Trunc(V), Q, P); else Result := Gray32(0); end; end; procedure RGBToHSV(Color: TColor32; out H, S, V: Single); var Delta, Min, Max: Single; R, G, B: Integer; const COneSixth = 1 / 6; begin R := RedComponent(Color); G := GreenComponent(Color); B := BlueComponent(Color); Min := MinIntValue([R, G, B]); Max := MaxIntValue([R, G, B]); V := Max / 255; Delta := Max - Min; if Max = 0 then S := 0 else S := Delta / Max; if S = 0.0 then H := 0 else begin if R = Max then H := COneSixth * (G - B) / Delta else if G = Max then H := COneSixth * (2 + (B - R) / Delta) else if B = Max then H := COneSixth * (4 + (R - G) / Delta); if H < 0.0 then H := H + 1; end; end; { Palette conversion } function WinPalette(const P: TPalette32): HPALETTE; var L: TMaxLogPalette; L0: LOGPALETTE absolute L; I: Cardinal; Cl: TColor32; begin L.palVersion := $300; L.palNumEntries := 256; for I := 0 to $FF do begin Cl := P[I]; with L.palPalEntry[I] do begin peFlags := 0; peRed := RedComponent(Cl); peGreen := GreenComponent(Cl); peBlue := BlueComponent(Cl); end; end; Result := CreatePalette(l0); end; { Fixed-point conversion routines } function Fixed(S: Single): TFixed; begin Result := Round(S * FixedOne); end; function Fixed(I: Integer): TFixed; begin Result := I shl 16; end; { Points } function Point(X, Y: Integer): TPoint; begin Result.X := X; Result.Y := Y; end; function Point(const FP: TFloatPoint): TPoint; begin Result.X := Round(FP.X); Result.Y := Round(FP.Y); end; function Point(const FXP: TFixedPoint): TPoint; begin Result.X := FixedRound(FXP.X); Result.Y := FixedRound(FXP.Y); end; function FloatPoint(X, Y: Single): TFloatPoint; begin Result.X := X; Result.Y := Y; end; function FloatPoint(const P: TPoint): TFloatPoint; begin Result.X := P.X; Result.Y := P.Y; end; function FloatPoint(const FXP: TFixedPoint): TFloatPoint; begin with FXP do begin Result.X := X * FixedToFloat; Result.Y := Y * FixedToFloat; end; end; {$IFDEF SUPPORT_ENHANCED_RECORDS} {$IFNDEF FPC} constructor TFloatPoint.Create(P: TPoint); begin Self.X := P.X; Self.Y := P.Y; end; {$IFDEF COMPILERXE2_UP} constructor TFloatPoint.Create(P: TPointF); begin Self.X := P.X; Self.Y := P.Y; end; {$ENDIF} constructor TFloatPoint.Create(X, Y: Integer); begin Self.X := X; Self.Y := Y; end; constructor TFloatPoint.Create(X, Y: TFloat); begin Self.X := X; Self.Y := Y; end; {$ENDIF} // operator overloads class operator TFloatPoint.Equal(const Lhs, Rhs: TFloatPoint): Boolean; begin Result := (Lhs.X = Rhs.X) and (Lhs.Y = Rhs.Y); end; class operator TFloatPoint.NotEqual(const Lhs, Rhs: TFloatPoint): Boolean; begin Result := (Lhs.X <> Rhs.X) or (Lhs.Y <> Rhs.Y); end; class operator TFloatPoint.Add(const Lhs, Rhs: TFloatPoint): TFloatPoint; begin Result.X := Lhs.X + Rhs.X; Result.Y := Lhs.Y + Rhs.Y; end; class operator TFloatPoint.Subtract(const Lhs, Rhs: TFloatPoint): TFloatPoint; begin Result.X := Lhs.X - Rhs.X; Result.Y := Lhs.Y - Rhs.Y; end; {$IFDEF COMPILERXE2_UP} class operator TFloatPoint.Explicit(A: TPointF): TFloatPoint; begin Result.X := A.X; Result.Y := A.Y; end; class operator TFloatPoint.Implicit(A: TPointF): TFloatPoint; begin Result.X := A.X; Result.Y := A.Y; end; {$ENDIF} class function TFloatPoint.Zero: TFloatPoint; begin Result.X := 0; Result.Y := 0; end; {$IFNDEF FPC} {$IFDEF COMPILERXE2_UP} constructor TFixedPoint.Create(P: TPointF); begin Self.X := Fixed(P.X); Self.Y := Fixed(P.Y); end; {$ENDIF} constructor TFixedPoint.Create(P: TFloatPoint); begin Self.X := Fixed(P.X); Self.Y := Fixed(P.Y); end; constructor TFixedPoint.Create(X, Y: TFixed); begin Self.X := X; Self.Y := Y; end; constructor TFixedPoint.Create(X, Y: Integer); begin Self.X := Fixed(X); Self.Y := Fixed(Y); end; constructor TFixedPoint.Create(X, Y: TFloat); begin Self.X := Fixed(X); Self.Y := Fixed(Y); end; {$ENDIF} // operator overloads class operator TFixedPoint.Equal(const Lhs, Rhs: TFixedPoint): Boolean; begin Result := (Lhs.X = Rhs.X) and (Lhs.Y = Rhs.Y); end; class operator TFixedPoint.NotEqual(const Lhs, Rhs: TFixedPoint): Boolean; begin Result := (Lhs.X <> Rhs.X) or (Lhs.Y <> Rhs.Y); end; class operator TFixedPoint.Add(const Lhs, Rhs: TFixedPoint): TFixedPoint; begin Result.X := Lhs.X + Rhs.X; Result.Y := Lhs.Y + Rhs.Y; end; class operator TFixedPoint.Subtract(const Lhs, Rhs: TFixedPoint): TFixedPoint; begin Result.X := Lhs.X - Rhs.X; Result.Y := Lhs.Y - Rhs.Y; end; class function TFixedPoint.Zero: TFixedPoint; begin Result.X := 0; Result.Y := 0; end; {$ENDIF} function FixedPoint(X, Y: Integer): TFixedPoint; overload; begin Result.X := X shl 16; Result.Y := Y shl 16; end; function FixedPoint(X, Y: Single): TFixedPoint; overload; begin Result.X := Round(X * FixedOne); Result.Y := Round(Y * FixedOne); end; function FixedPoint(const P: TPoint): TFixedPoint; overload; begin Result.X := P.X shl 16; Result.Y := P.Y shl 16; end; function FixedPoint(const FP: TFloatPoint): TFixedPoint; overload; begin Result.X := Round(FP.X * FixedOne); Result.Y := Round(FP.Y * FixedOne); end; { Rectangles } function MakeRect(const L, T, R, B: Integer): TRect; begin with Result do begin Left := L; Top := T; Right := R; Bottom := B; end; end; function MakeRect(const FR: TFloatRect; Rounding: TRectRounding): TRect; begin with FR do case Rounding of rrClosest: begin Result.Left := Round(Left); Result.Top := Round(Top); Result.Right := Round(Right); Result.Bottom := Round(Bottom); end; rrInside: begin Result.Left := Ceil(Left); Result.Top := Ceil(Top); Result.Right := Floor(Right); Result.Bottom := Floor(Bottom); if Result.Right < Result.Left then Result.Right := Result.Left; if Result.Bottom < Result.Top then Result.Bottom := Result.Top; end; rrOutside: begin Result.Left := Floor(Left); Result.Top := Floor(Top); Result.Right := Ceil(Right); Result.Bottom := Ceil(Bottom); end; end; end; function MakeRect(const FXR: TFixedRect; Rounding: TRectRounding): TRect; begin with FXR do case Rounding of rrClosest: begin Result.Left := FixedRound(Left); Result.Top := FixedRound(Top); Result.Right := FixedRound(Right); Result.Bottom := FixedRound(Bottom); end; rrInside: begin Result.Left := FixedCeil(Left); Result.Top := FixedCeil(Top); Result.Right := FixedFloor(Right); Result.Bottom := FixedFloor(Bottom); if Result.Right < Result.Left then Result.Right := Result.Left; if Result.Bottom < Result.Top then Result.Bottom := Result.Top; end; rrOutside: begin Result.Left := FixedFloor(Left); Result.Top := FixedFloor(Top); Result.Right := FixedCeil(Right); Result.Bottom := FixedCeil(Bottom); end; end; end; function FixedRect(const L, T, R, B: TFixed): TFixedRect; begin with Result do begin Left := L; Top := T; Right := R; Bottom := B; end; end; function FixedRect(const TopLeft, BottomRight: TFixedPoint): TFixedRect; begin Result.TopLeft := TopLeft; Result.BottomRight := BottomRight; end; function FixedRect(const ARect: TRect): TFixedRect; begin with Result do begin Left := ARect.Left shl 16; Top := ARect.Top shl 16; Right := ARect.Right shl 16; Bottom := ARect.Bottom shl 16; end; end; function FixedRect(const FR: TFloatRect): TFixedRect; begin with Result do begin Left := Round(FR.Left * 65536); Top := Round(FR.Top * 65536); Right := Round(FR.Right * 65536); Bottom := Round(FR.Bottom * 65536); end; end; function FloatRect(const L, T, R, B: TFloat): TFloatRect; begin with Result do begin Left := L; Top := T; Right := R; Bottom := B; end; end; function FloatRect(const TopLeft, BottomRight: TFloatPoint): TFloatRect; begin Result.TopLeft := TopLeft; Result.BottomRight := BottomRight; end; function FloatRect(const ARect: TRect): TFloatRect; begin with Result do begin Left := ARect.Left; Top := ARect.Top; Right := ARect.Right; Bottom := ARect.Bottom; end; end; function FloatRect(const FXR: TFixedRect): TFloatRect; begin with Result do begin Left := FXR.Left * FixedToFloat; Top := FXR.Top * FixedToFloat; Right := FXR.Right * FixedToFloat; Bottom := FXR.Bottom * FixedToFloat; end; end; function IntersectRect(out Dst: TRect; const R1, R2: TRect): Boolean; begin if R1.Left >= R2.Left then Dst.Left := R1.Left else Dst.Left := R2.Left; if R1.Right <= R2.Right then Dst.Right := R1.Right else Dst.Right := R2.Right; if R1.Top >= R2.Top then Dst.Top := R1.Top else Dst.Top := R2.Top; if R1.Bottom <= R2.Bottom then Dst.Bottom := R1.Bottom else Dst.Bottom := R2.Bottom; Result := (Dst.Right >= Dst.Left) and (Dst.Bottom >= Dst.Top); if not Result then Dst := ZERO_RECT; end; function IntersectRect(out Dst: TFloatRect; const FR1, FR2: TFloatRect): Boolean; begin Dst.Left := Math.Max(FR1.Left, FR2.Left); Dst.Right := Math.Min(FR1.Right, FR2.Right); Dst.Top := Math.Max(FR1.Top, FR2.Top); Dst.Bottom := Math.Min(FR1.Bottom, FR2.Bottom); Result := (Dst.Right >= Dst.Left) and (Dst.Bottom >= Dst.Top); if not Result then FillLongword(Dst, 4, 0); end; function UnionRect(out Rect: TRect; const R1, R2: TRect): Boolean; begin Rect := R1; if not IsRectEmpty(R2) then begin if R2.Left < R1.Left then Rect.Left := R2.Left; if R2.Top < R1.Top then Rect.Top := R2.Top; if R2.Right > R1.Right then Rect.Right := R2.Right; if R2.Bottom > R1.Bottom then Rect.Bottom := R2.Bottom; end; Result := not IsRectEmpty(Rect); if not Result then Rect := ZERO_RECT; end; function UnionRect(out Rect: TFloatRect; const R1, R2: TFloatRect): Boolean; begin Rect := R1; if not IsRectEmpty(R2) then begin if R2.Left < R1.Left then Rect.Left := R2.Left; if R2.Top < R1.Top then Rect.Top := R2.Top; if R2.Right > R1.Right then Rect.Right := R2.Right; if R2.Bottom > R1.Bottom then Rect.Bottom := R2.Bottom; end; Result := not IsRectEmpty(Rect); if not Result then FillLongword(Rect, 4, 0); end; function EqualRect(const R1, R2: TRect): Boolean; begin Result := CompareMem(@R1, @R2, SizeOf(TRect)); end; function EqualRect(const R1, R2: TFloatRect): Boolean; begin Result := CompareMem(@R1, @R2, SizeOf(TFloatRect)); end; function EqualRectSize(const R1, R2: TRect): Boolean; begin Result := ((R1.Right - R1.Left) = (R2.Right - R2.Left)) and ((R1.Bottom - R1.Top) = (R2.Bottom - R2.Top)); end; function EqualRectSize(const R1, R2: TFloatRect): Boolean; var _R1: TFixedRect; _R2: TFixedRect; begin _R1 := FixedRect(R1); _R2 := FixedRect(R2); Result := ((_R1.Right - _R1.Left) = (_R2.Right - _R2.Left)) and ((_R1.Bottom - _R1.Top) = (_R2.Bottom - _R2.Top)); end; procedure InflateRect(var R: TRect; Dx, Dy: Integer); begin Dec(R.Left, Dx); Dec(R.Top, Dy); Inc(R.Right, Dx); Inc(R.Bottom, Dy); end; procedure InflateRect(var FR: TFloatRect; Dx, Dy: TFloat); begin with FR do begin Left := Left - Dx; Top := Top - Dy; Right := Right + Dx; Bottom := Bottom + Dy; end; end; procedure OffsetRect(var R: TRect; Dx, Dy: Integer); begin Inc(R.Left, Dx); Inc(R.Top, Dy); Inc(R.Right, Dx); Inc(R.Bottom, Dy); end; procedure OffsetRect(var FR: TFloatRect; Dx, Dy: TFloat); begin with FR do begin Left := Left + Dx; Top := Top + Dy; Right := Right + Dx; Bottom := Bottom + Dy; end; end; function IsRectEmpty(const R: TRect): Boolean; begin Result := (R.Right <= R.Left) or (R.Bottom <= R.Top); end; function IsRectEmpty(const FR: TFloatRect): Boolean; begin Result := (FR.Right <= FR.Left) or (FR.Bottom <= FR.Top); end; function PtInRect(const R: TRect; const P: TPoint): Boolean; begin Result := (P.X >= R.Left) and (P.X < R.Right) and (P.Y >= R.Top) and (P.Y < R.Bottom); end; function PtInRect(const R: TFloatRect; const P: TPoint): Boolean; begin Result := (P.X >= R.Left) and (P.X < R.Right) and (P.Y >= R.Top) and (P.Y < R.Bottom); end; function PtInRect(const R: TRect; const P: TFloatPoint): Boolean; begin Result := (P.X >= R.Left) and (P.X < R.Right) and (P.Y >= R.Top) and (P.Y < R.Bottom); end; function PtInRect(const R: TFloatRect; const P: TFloatPoint): Boolean; begin Result := (P.X >= R.Left) and (P.X < R.Right) and (P.Y >= R.Top) and (P.Y < R.Bottom); end; { Gamma / Pixel Shape Correction table } procedure SetGamma(Gamma: Single); var i: Integer; begin for i := 0 to $FF do GAMMA_TABLE[i] := Round($FF * Power(i * COne255th, Gamma)); end; { TSimpleInterfacedPersistent } function TPlainInterfacedPersistent._AddRef: Integer; begin if FRefCounted then Result := InterlockedIncrement(FRefCount) else Result := -1; end; function TPlainInterfacedPersistent._Release: Integer; begin if FRefCounted then begin Result := InterlockedDecrement(FRefCount); if Result = 0 then Destroy; end else Result := -1; end; function TPlainInterfacedPersistent.QueryInterface( {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF}IID: TGUID; out Obj): HResult; const E_NOINTERFACE = HResult($80004002); begin if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE; end; procedure TPlainInterfacedPersistent.AfterConstruction; begin inherited; // Release the constructor's implicit refcount InterlockedDecrement(FRefCount); end; procedure TPlainInterfacedPersistent.BeforeDestruction; begin if RefCounted and (RefCount <> 0) then raise Exception.Create(RCStrUnmatchedReferenceCounting); inherited; end; class function TPlainInterfacedPersistent.NewInstance: TObject; begin Result := inherited NewInstance; // Set an implicit refcount so that refcounting // during construction won't destroy the object. TPlainInterfacedPersistent(Result).FRefCount := 1; end; { TNotifiablePersistent } procedure TNotifiablePersistent.BeginUpdate; begin Inc(FUpdateCount); end; procedure TNotifiablePersistent.Changed; begin if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self); end; procedure TNotifiablePersistent.EndUpdate; begin Assert(FUpdateCount > 0, 'Unpaired TThreadPersistent.EndUpdate'); Dec(FUpdateCount); end; { TThreadPersistent } constructor TThreadPersistent.Create; begin InitializeCriticalSection(FLock); end; destructor TThreadPersistent.Destroy; begin DeleteCriticalSection(FLock); inherited; end; procedure TThreadPersistent.Lock; begin InterlockedIncrement(FLockCount); EnterCriticalSection(FLock); end; procedure TThreadPersistent.Unlock; begin LeaveCriticalSection(FLock); InterlockedDecrement(FLockCount); end; { TCustomMap } constructor TCustomMap.Create(Width, Height: Integer); begin Create; SetSize(Width, Height); end; procedure TCustomMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); begin Width := NewWidth; Height := NewHeight; end; procedure TCustomMap.Delete; begin SetSize(0, 0); end; function TCustomMap.Empty: Boolean; begin Result := (Width = 0) or (Height = 0); end; procedure TCustomMap.Resized; begin if Assigned(FOnResize) then FOnResize(Self); end; procedure TCustomMap.SetHeight(NewHeight: Integer); begin SetSize(Width, NewHeight); end; function TCustomMap.SetSize(NewWidth, NewHeight: Integer): Boolean; begin if NewWidth < 0 then NewWidth := 0; if NewHeight < 0 then NewHeight := 0; Result := (NewWidth <> FWidth) or (NewHeight <> FHeight); if Result then begin ChangeSize(FWidth, FHeight, NewWidth, NewHeight); Changed; Resized; end; end; function TCustomMap.SetSizeFrom(Source: TPersistent): Boolean; begin if Source is TCustomMap then Result := SetSize(TCustomMap(Source).Width, TCustomMap(Source).Height) else if Source is TGraphic then Result := SetSize(TGraphic(Source).Width, TGraphic(Source).Height) else if Source is TControl then Result := SetSize(TControl(Source).Width, TControl(Source).Height) else if Source = nil then Result := SetSize(0, 0) else raise Exception.CreateFmt(RCStrCannotSetSize, [Source.ClassName]); end; procedure TCustomMap.SetWidth(NewWidth: Integer); begin SetSize(NewWidth, Height); end; { TCustomBitmap32 } constructor TCustomBitmap32.Create(Backend: TCustomBackendClass); begin inherited Create; InitializeBackend(Backend); FOuterColor := $00000000; // by default as full transparency black FMasterAlpha := $FF; FPenColor := clWhite32; FStippleStep := 1; FCombineMode := cmBlend; BlendProc := @BLEND_MEM[FCombineMode]^; WrapProcHorz := GetWrapProcEx(WrapMode); WrapProcVert := GetWrapProcEx(WrapMode); FResampler := TNearestResampler.Create(Self); end; constructor TCustomBitmap32.Create; begin Create(GetPlatformBackendClass); end; destructor TCustomBitmap32.Destroy; begin BeginUpdate; Lock; try SetSize(0, 0); FResampler.Free; FinalizeBackend; finally Unlock; end; inherited; end; procedure TCustomBitmap32.InitializeBackend(Backend: TCustomBackendClass); begin Backend.Create(Self); end; procedure TCustomBitmap32.FinalizeBackend; begin // Drop ownership of backend now: // It's a zombie now. FBackend.FOwner := nil; FBackend.OnChange := nil; FBackend.OnChanging := nil; (* Release our reference to the backend Note: The backend won't necessarily be freed immediately. This is required to circumvent a problem with the magic procedure cleanup of interfaces that have ref-counting forcefully disabled: Quality Central report #9157 and #9500: http://qc.codegear.com/wc/qcmain.aspx?d=9157 http://qc.codegear.com/wc/qcmain.aspx?d=9500 if any backend interface is used within the same procedure in which the owner bitmap is also freed, the magic procedure cleanup will clear that particular interface long after the bitmap and its backend are gone. This will result in all sorts of madness - mostly heap corruption and AVs. Here is an example: procedure Test; var MyBitmap: TBitmap32; begin MyBitmap := TBitmap32.Create; MyBitmap.SetSize(100, 100); (MyBitmap.Backend as ICanvasSupport).Canvas; MyBitmap.Free; end; // _IntfClear will try to clear (MyBitmap.Backend as ICanvasSupport) // which points to the interface at the previous location of MyBitmap.Backend in memory. // MyBitmap.Backend is gone and the _Release call is invalid, so raise hell . Here is an example for a correct workaround: procedure Test; var MyBitmap: TBitmap32; CanvasIntf: ICanvasSupport; begin MyBitmap := TBitmap32.Create; MyBitmap.SetSize(100, 100); CanvasIntf := MyBitmap.Backend as ICanvasSupport; CanvasIntf.Canvas; CanvasIntf := nil; // this will call _IntfClear and IInterface._Release MyBitmap.Free; end; // _IntfClear will try to clear CanvasIntf, // it's nil, no _Release is called, everything is fine. Since the above code is pretty fiddly, we introduce ref-counting for the backend. That way the backend will be released once all references are dropped. So, release our reference to the backend now: *) FBackend._Release; FBackend := nil; end; procedure TCustomBitmap32.SetBackend(const Backend: TCustomBackend); begin if Assigned(Backend) and (Backend <> FBackend) then begin BeginUpdate; Backend.FOwner := Self; if Assigned(FBackend) then begin Backend.Assign(FBackend); FinalizeBackend; end; FBackend := Backend; FBackend.OnChange := BackendChangedHandler; FBackend.OnChanging := BackendChangingHandler; EndUpdate; FBackend.Changed; Changed; end; end; function TCustomBitmap32.ReleaseBackend: TCustomBackend; begin FBackend._AddRef; // Increase ref-count for external use Result := FBackend; end; function TCustomBitmap32.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; begin Result := FBackend.QueryInterface(IID, Obj); if Result <> S_OK then Result := inherited QueryInterface(IID, Obj); end; procedure TCustomBitmap32.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); begin FBackend.ChangeSize(Width, Height, NewWidth, NewHeight); end; procedure TCustomBitmap32.BackendChangingHandler(Sender: TObject); begin // descendants can override this method. end; procedure TCustomBitmap32.BackendChangedHandler(Sender: TObject); begin FBits := FBackend.Bits; ResetClipRect; end; function TCustomBitmap32.Empty: Boolean; begin Result := FBackend.Empty or inherited Empty; end; procedure TCustomBitmap32.Clear; begin Clear(clBlack32); end; procedure TCustomBitmap32.Clear(FillColor: TColor32); begin if Empty then Exit; if not MeasuringMode then if Clipping then FillRect(FClipRect.Left, FClipRect.Top, FClipRect.Right, FClipRect.Bottom, FillColor) else FillLongword(Bits[0], Width * Height, FillColor); Changed; end; procedure TCustomBitmap32.Delete; begin SetSize(0, 0); end; procedure TCustomBitmap32.AssignTo(Dst: TPersistent); procedure AssignToBitmap(Bmp: TBitmap; SrcBitmap: TCustomBitmap32); var SavedBackend: TCustomBackend; begin RequireBackendSupport(SrcBitmap, [IDeviceContextSupport], romOr, False, SavedBackend); try Bmp.HandleType := bmDIB; Bmp.PixelFormat := pf32Bit; {$IFDEF COMPILER2009_UP} Bmp.SetSize(SrcBitmap.Width, SrcBitmap.Height); {$ELSE} Bmp.Width := SrcBitmap.Width; Bmp.Height := SrcBitmap.Height; {$ENDIF} if Supports(SrcBitmap.Backend, IFontSupport) then // this is optional Bmp.Canvas.Font.Assign((SrcBitmap.Backend as IFontSupport).Font); if SrcBitmap.Empty then Exit; Bmp.Canvas.Lock; try (SrcBitmap.Backend as IDeviceContextSupport).DrawTo(Bmp.Canvas.Handle, BoundsRect, BoundsRect) finally Bmp.Canvas.UnLock; end; finally RestoreBackend(SrcBitmap, SavedBackend); end; end; var Bmp: TBitmap; begin if Dst is TPicture then AssignToBitmap(TPicture(Dst).Bitmap, Self) else if Dst is TBitmap then AssignToBitmap(TBitmap(Dst), Self) else if Dst is TClipboard then begin Bmp := TBitmap.Create; try AssignToBitmap(Bmp, Self); TClipboard(Dst).Assign(Bmp); finally Bmp.Free; end; end else inherited; end; procedure TCustomBitmap32.Assign(Source: TPersistent); procedure AssignFromGraphicPlain(TargetBitmap: TCustomBitmap32; SrcGraphic: TGraphic; FillColor: TColor32; ResetAlphaAfterDrawing: Boolean); var SavedBackend: TCustomBackend; Canvas: TCanvas; begin if not Assigned(SrcGraphic) then Exit; RequireBackendSupport(TargetBitmap, [IDeviceContextSupport, ICanvasSupport], romOr, True, SavedBackend); try TargetBitmap.SetSize(SrcGraphic.Width, SrcGraphic.Height); if TargetBitmap.Empty then Exit; TargetBitmap.Clear(FillColor); if Supports(TargetBitmap.Backend, IDeviceContextSupport) then begin Canvas := TCanvas.Create; try Canvas.Lock; try Canvas.Handle := (TargetBitmap.Backend as IDeviceContextSupport).Handle; TGraphicAccess(SrcGraphic).Draw(Canvas, MakeRect(0, 0, TargetBitmap.Width, TargetBitmap.Height)); finally Canvas.Unlock; end; finally Canvas.Free; end; end else if Supports(TargetBitmap.Backend, ICanvasSupport) then TGraphicAccess(SrcGraphic).Draw((TargetBitmap.Backend as ICanvasSupport).Canvas, MakeRect(0, 0, TargetBitmap.Width, TargetBitmap.Height)) else raise Exception.Create(RCStrInpropriateBackend); if ResetAlphaAfterDrawing then ResetAlpha; finally RestoreBackend(TargetBitmap, SavedBackend); end; end; procedure AssignFromGraphicMasked(TargetBitmap: TCustomBitmap32; SrcGraphic: TGraphic); var TempBitmap: TCustomBitmap32; I: integer; DstP, SrcP: PColor32; DstColor: TColor32; begin AssignFromGraphicPlain(TargetBitmap, SrcGraphic, clWhite32, False); // mask on white if TargetBitmap.Empty then begin TargetBitmap.Clear; Exit; end; TempBitmap := TCustomBitmap32.Create; try AssignFromGraphicPlain(TempBitmap, SrcGraphic, clRed32, False); // mask on red DstP := @TargetBitmap.Bits[0]; SrcP := @TempBitmap.Bits[0]; for I := 0 to TargetBitmap.Width * TargetBitmap.Height - 1 do begin DstColor := DstP^ and $00FFFFFF; // this checks for transparency by comparing the pixel-color of the // temporary bitmap (red masked) with the pixel of our // bitmap (white masked). if they match, make that pixel opaque if DstColor = (SrcP^ and $00FFFFFF) then DstP^ := DstColor or $FF000000 else // if the colors do not match (that is the case if there is a // match "is clRed32 = clWhite32 ?"), just make that pixel // transparent: DstP^ := DstColor; Inc(SrcP); Inc(DstP); end; finally TempBitmap.Free; end; end; procedure AssignFromBitmap(TargetBitmap: TCustomBitmap32; SrcBmp: TBitmap); var TransparentColor: TColor32; DstP: PColor32; I: integer; DstColor: TColor32; begin AssignFromGraphicPlain(TargetBitmap, SrcBmp, 0, SrcBmp.PixelFormat <> pf32bit); if TargetBitmap.Empty then Exit; if SrcBmp.Transparent then begin TransparentColor := Color32(SrcBmp.TransparentColor) and $00FFFFFF; DstP := @TargetBitmap.Bits[0]; for I := 0 to TargetBitmap.Width * TargetBitmap.Height - 1 do begin DstColor := DstP^ and $00FFFFFF; if DstColor = TransparentColor then DstP^ := DstColor; Inc(DstP); end; end; if Supports(TargetBitmap.Backend, IFontSupport) then // this is optional (TargetBitmap.Backend as IFontSupport).Font.Assign(SrcBmp.Canvas.Font); end; procedure AssignFromIcon(TargetBitmap: TCustomBitmap32; SrcIcon: TIcon); var I: Integer; P: PColor32Entry; ReassignFromMasked: Boolean; begin AssignFromGraphicPlain(TargetBitmap, SrcIcon, 0, False); if TargetBitmap.Empty then Exit; // Check if the icon was painted with a merged alpha channel. // The happens transparently for new-style 32-bit icons. // For all other bit depths GDI will reset our alpha channel to opaque. ReassignFromMasked := True; P := PColor32Entry(@TargetBitmap.Bits[0]); for I := 0 to TargetBitmap.Height * TargetBitmap.Width - 1 do begin if P.A > 0 then begin ReassignFromMasked := False; Break; end; Inc(P); end; // No alpha values found? Use masked approach... if ReassignFromMasked then AssignFromGraphicMasked(TargetBitmap, SrcIcon); end; procedure AssignFromGraphic(TargetBitmap: TCustomBitmap32; SrcGraphic: TGraphic); begin if SrcGraphic is TBitmap then AssignFromBitmap(TargetBitmap, TBitmap(SrcGraphic)) else if SrcGraphic is TIcon then AssignFromIcon(TargetBitmap, TIcon(SrcGraphic)) {$IFNDEF PLATFORM_INDEPENDENT} else if SrcGraphic is TMetaFile then AssignFromGraphicMasked(TargetBitmap, SrcGraphic) {$ENDIF} else AssignFromGraphicPlain(TargetBitmap, SrcGraphic, clWhite32, True); end; var Picture: TPicture; begin BeginUpdate; try if not Assigned(Source) then SetSize(0, 0) else if Source is TCustomBitmap32 then begin TCustomBitmap32(Source).CopyMapTo(Self); TCustomBitmap32(Source).CopyPropertiesTo(Self); end else if Source is TGraphic then AssignFromGraphic(Self, TGraphic(Source)) else if Source is TPicture then AssignFromGraphic(Self, TPicture(Source).Graphic) else if Source is TClipboard then begin Picture := TPicture.Create; try Picture.Assign(TClipboard(Source)); AssignFromGraphic(Self, Picture.Graphic); finally Picture.Free; end; end else inherited; // default handler finally; EndUpdate; Changed; end; end; procedure TCustomBitmap32.CopyMapTo(Dst: TCustomBitmap32); begin Dst.SetSize(Width, Height); if not Empty then MoveLongword(Bits[0], Dst.Bits[0], Width * Height); end; procedure TCustomBitmap32.CopyPropertiesTo(Dst: TCustomBitmap32); begin with Dst do begin DrawMode := Self.DrawMode; CombineMode := Self.CombineMode; WrapMode := Self.WrapMode; MasterAlpha := Self.MasterAlpha; OuterColor := Self.OuterColor; {$IFDEF DEPRECATEDMODE} StretchFilter := Self.StretchFilter; {$ENDIF} ResamplerClassName := Self.ResamplerClassName; if Assigned(Resampler) and Assigned(Self.Resampler) then Resampler.Assign(Self.Resampler); end; end; {$IFDEF BITS_GETTER} function TCustomBitmap32.GetBits: PColor32Array; begin Result := FBackend.Bits; end; {$ENDIF} procedure TCustomBitmap32.SetPixel(X, Y: Integer; Value: TColor32); begin Bits[X + Y * Width] := Value; end; procedure TCustomBitmap32.SetPixelS(X, Y: Integer; Value: TColor32); begin if {$IFDEF CHANGED_IN_PIXELS}not FMeasuringMode and{$ENDIF} (X >= FClipRect.Left) and (X < FClipRect.Right) and (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then Bits[X + Y * Width] := Value; {$IFDEF CHANGED_IN_PIXELS} Changed(MakeRect(X, Y, X + 1, Y + 1)); {$ENDIF} end; function TCustomBitmap32.GetScanLine(Y: Integer): PColor32Array; begin Result := @Bits[Y * FWidth]; end; function TCustomBitmap32.GetPixel(X, Y: Integer): TColor32; begin Result := Bits[X + Y * Width]; end; function TCustomBitmap32.GetPixelS(X, Y: Integer): TColor32; begin if (X >= FClipRect.Left) and (X < FClipRect.Right) and (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then Result := Bits[X + Y * Width] else Result := OuterColor; end; function TCustomBitmap32.GetPixelPtr(X, Y: Integer): PColor32; begin Result := @Bits[X + Y * Width]; end; procedure TCustomBitmap32.Draw(DstX, DstY: Integer; Src: TCustomBitmap32); begin if Assigned(Src) then Src.DrawTo(Self, DstX, DstY); end; procedure TCustomBitmap32.Draw(DstX, DstY: Integer; const SrcRect: TRect; Src: TCustomBitmap32); begin if Assigned(Src) then Src.DrawTo(Self, DstX, DstY, SrcRect); end; procedure TCustomBitmap32.Draw(const DstRect, SrcRect: TRect; Src: TCustomBitmap32); begin if Assigned(Src) then Src.DrawTo(Self, DstRect, SrcRect); end; procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32); begin BlockTransfer(Dst, 0, 0, Dst.ClipRect, Self, BoundsRect, DrawMode, FOnPixelCombine); end; procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer); begin BlockTransfer(Dst, DstX, DstY, Dst.ClipRect, Self, BoundsRect, DrawMode, FOnPixelCombine); end; procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer; const SrcRect: TRect); begin BlockTransfer(Dst, DstX, DstY, Dst.ClipRect, Self, SrcRect, DrawMode, FOnPixelCombine); end; procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; const DstRect: TRect); begin StretchTransfer(Dst, DstRect, Dst.ClipRect, Self, BoundsRect, Resampler, DrawMode, FOnPixelCombine); end; procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; const DstRect, SrcRect: TRect); begin StretchTransfer(Dst, DstRect, Dst.ClipRect, Self, SrcRect, Resampler, DrawMode, FOnPixelCombine); end; procedure TCustomBitmap32.ResetAlpha; begin ResetAlpha($FF); end; procedure TCustomBitmap32.ResetAlpha(const AlphaValue: Byte); var I: Integer; P: PByteArray; begin if not FMeasuringMode then begin {$IFDEF FPC} P := Pointer(Bits); for I := 0 to Width * Height - 1 do begin P^[3] := AlphaValue; Inc(P, 4); end {$ELSE} P := Pointer(Bits); Inc(P, 3); //shift the pointer to 'alpha' component of the first pixel I := Width * Height; if I > 16 then begin I := I * 4 - 64; Inc(P, I); //16x enrolled loop I := - I; repeat P^[I] := AlphaValue; P^[I + 4] := AlphaValue; P^[I + 8] := AlphaValue; P^[I + 12] := AlphaValue; P^[I + 16] := AlphaValue; P^[I + 20] := AlphaValue; P^[I + 24] := AlphaValue; P^[I + 28] := AlphaValue; P^[I + 32] := AlphaValue; P^[I + 36] := AlphaValue; P^[I + 40] := AlphaValue; P^[I + 44] := AlphaValue; P^[I + 48] := AlphaValue; P^[I + 52] := AlphaValue; P^[I + 56] := AlphaValue; P^[I + 60] := AlphaValue; Inc(I, 64) until I > 0; //eventually remaining bits Dec(I, 64); while I < 0 do begin P^[I + 64] := AlphaValue; Inc(I, 4); end; end else begin Dec(I); I := I * 4; while I >= 0 do begin P^[I] := AlphaValue; Dec(I, 4); end; end; {$ENDIF} end; Changed; end; function TCustomBitmap32.GetPixelB(X, Y: Integer): TColor32; begin // WARNING: this function should never be used on empty bitmaps !!! if X < 0 then X := 0 else if X >= Width then X := Width - 1; if Y < 0 then Y := 0 else if Y >= Height then Y := Height - 1; Result := Bits[X + Y * Width]; end; procedure TCustomBitmap32.SetPixelT(X, Y: Integer; Value: TColor32); begin TBlendMem(BlendProc)(Value, Bits[X + Y * Width]); EMMS; end; procedure TCustomBitmap32.SetPixelT(var Ptr: PColor32; Value: TColor32); begin TBlendMem(BlendProc)(Value, Ptr^); Inc(Ptr); EMMS; end; procedure TCustomBitmap32.SetPixelTS(X, Y: Integer; Value: TColor32); begin if {$IFDEF CHANGED_IN_PIXELS}not FMeasuringMode and{$ENDIF} (X >= FClipRect.Left) and (X < FClipRect.Right) and (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then begin TBlendMem(BlendProc)(Value, Bits[X + Y * Width]); EMMS; end; {$IFDEF CHANGED_IN_PIXELS} Changed(MakeRect(X, Y, X + 1, Y + 1)); {$ENDIF} end; procedure TCustomBitmap32.SET_T256(X, Y: Integer; C: TColor32); var flrx, flry, celx, cely: Longword; P: PColor32; A: TColor32; begin { Warning: EMMS should be called after using this method } flrx := X and $FF; flry := Y and $FF; {$IFDEF USENATIVECODE} X := X div 256; Y := Y div 256; {$ELSE} asm SAR X, 8 SAR Y, 8 end; {$ENDIF} P := @Bits[X + Y * FWidth]; if FCombineMode = cmBlend then begin A := C shr 24; // opacity celx := A * GAMMA_TABLE[flrx xor $FF]; cely := GAMMA_TABLE[flry xor $FF]; flrx := A * GAMMA_TABLE[flrx]; flry := GAMMA_TABLE[flry]; CombineMem(C, P^, celx * cely shr 16); Inc(P); CombineMem(C, P^, flrx * cely shr 16); Inc(P, FWidth); CombineMem(C, P^, flrx * flry shr 16); Dec(P); CombineMem(C, P^, celx * flry shr 16); end else begin celx := GAMMA_TABLE[flrx xor $FF]; cely := GAMMA_TABLE[flry xor $FF]; flrx := GAMMA_TABLE[flrx]; flry := GAMMA_TABLE[flry]; CombineMem(MergeReg(C, P^), P^, celx * cely shr 8); Inc(P); CombineMem(MergeReg(C, P^), P^, flrx * cely shr 8); Inc(P, FWidth); CombineMem(MergeReg(C, P^), P^, flrx * flry shr 8); Dec(P); CombineMem(MergeReg(C, P^), P^, celx * flry shr 8); end; end; procedure TCustomBitmap32.SET_TS256(X, Y: Integer; C: TColor32); var flrx, flry, celx, cely: Longword; P: PColor32; A: TColor32; begin { Warning: EMMS should be called after using this method } // we're checking against Left - 1 and Top - 1 due to antialiased values... if (X < F256ClipRect.Left - 256) or (X >= F256ClipRect.Right) or (Y < F256ClipRect.Top - 256) or (Y >= F256ClipRect.Bottom) then Exit; flrx := X and $FF; flry := Y and $FF; {$IFDEF USENATIVECODE} X := X div 256; Y := Y div 256; {$ELSE} asm SAR X, 8 SAR Y, 8 end; {$ENDIF} P := @Bits[X + Y * FWidth]; if FCombineMode = cmBlend then begin A := C shr 24; // opacity celx := A * GAMMA_TABLE[flrx xor $FF]; cely := GAMMA_TABLE[flry xor $FF]; flrx := A * GAMMA_TABLE[flrx]; flry := GAMMA_TABLE[flry]; if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and (X < FClipRect.Right - 1) and (Y < FClipRect.Bottom - 1) then begin CombineMem(C, P^, celx * cely shr 16); Inc(P); CombineMem(C, P^, flrx * cely shr 16); Inc(P, FWidth); CombineMem(C, P^, flrx * flry shr 16); Dec(P); CombineMem(C, P^, celx * flry shr 16); end else // "pixel" lies on the edge of the bitmap with FClipRect do begin if (X >= Left) and (Y >= Top) then CombineMem(C, P^, celx * cely shr 16); Inc(P); if (X < Right - 1) and (Y >= Top) then CombineMem(C, P^, flrx * cely shr 16); Inc(P, FWidth); if (X < Right - 1) and (Y < Bottom - 1) then CombineMem(C, P^, flrx * flry shr 16); Dec(P); if (X >= Left) and (Y < Bottom - 1) then CombineMem(C, P^, celx * flry shr 16); end; end else begin celx := GAMMA_TABLE[flrx xor $FF]; cely := GAMMA_TABLE[flry xor $FF]; flrx := GAMMA_TABLE[flrx]; flry := GAMMA_TABLE[flry]; if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and (X < FClipRect.Right - 1) and (Y < FClipRect.Bottom - 1) then begin CombineMem(MergeReg(C, P^), P^, celx * cely shr 8); Inc(P); CombineMem(MergeReg(C, P^), P^, flrx * cely shr 8); Inc(P, FWidth); CombineMem(MergeReg(C, P^), P^, flrx * flry shr 8); Dec(P); CombineMem(MergeReg(C, P^), P^, celx * flry shr 8); end else // "pixel" lies on the edge of the bitmap with FClipRect do begin if (X >= Left) and (Y >= Top) then CombineMem(MergeReg(C, P^), P^, celx * cely shr 8); Inc(P); if (X < Right - 1) and (Y >= Top) then CombineMem(MergeReg(C, P^), P^, flrx * cely shr 8); Inc(P, FWidth); if (X < Right - 1) and (Y < Bottom - 1) then CombineMem(MergeReg(C, P^), P^, flrx * flry shr 8); Dec(P); if (X >= Left) and (Y < Bottom - 1) then CombineMem(MergeReg(C, P^), P^, celx * flry shr 8); end; end; end; procedure TCustomBitmap32.SetPixelF(X, Y: Single; Value: TColor32); begin SET_T256(Round(X * 256), Round(Y * 256), Value); {$IFNDEF OMIT_MMX} EMMS; {$ENDIF} end; procedure TCustomBitmap32.SetPixelX(X, Y: TFixed; Value: TColor32); begin X := (X + $7F) shr 8; Y := (Y + $7F) shr 8; SET_T256(X, Y, Value); {$IFNDEF OMIT_MMX} EMMS; {$ENDIF} end; procedure TCustomBitmap32.SetPixelFS(X, Y: Single; Value: TColor32); begin {$IFDEF CHANGED_IN_PIXELS} if not FMeasuringMode then begin {$ENDIF} SET_TS256(Round(X * 256), Round(Y * 256), Value); EMMS; {$IFDEF CHANGED_IN_PIXELS} end; Changed(MakeRect(FloatRect(X, Y, X + 1, Y + 1))); {$ENDIF} end; procedure TCustomBitmap32.SetPixelFW(X, Y: Single; Value: TColor32); begin {$IFDEF CHANGED_IN_PIXELS} if not FMeasuringMode then begin {$ENDIF} SetPixelXW(Round(X * FixedOne), Round(Y * FixedOne), Value); EMMS; {$IFDEF CHANGED_IN_PIXELS} end; Changed(MakeRect(FloatRect(X, Y, X + 1, Y + 1))); {$ENDIF} end; procedure TCustomBitmap32.SetPixelXS(X, Y: TFixed; Value: TColor32); begin {$IFDEF CHANGED_IN_PIXELS} if not FMeasuringMode then begin {$ENDIF} {$IFDEF USENATIVECODE} X := (X + $7F) div 256; Y := (Y + $7F) div 256; {$ELSE} asm ADD X, $7F ADD Y, $7F SAR X, 8 SAR Y, 8 end; {$ENDIF} SET_TS256(X, Y, Value); EMMS; {$IFDEF CHANGED_IN_PIXELS} end; Changed(MakeRect(X, Y, X + 1, Y + 1)); {$ENDIF} end; function TCustomBitmap32.GET_T256(X, Y: Integer): TColor32; // When using this, remember that it interpolates towards next x and y! var Pos: Integer; begin Pos := (X shr 8) + (Y shr 8) * FWidth; Result := Interpolator(GAMMA_TABLE[X and $FF xor $FF], GAMMA_TABLE[Y and $FF xor $FF], @Bits[Pos], @Bits[Pos + FWidth]); end; function TCustomBitmap32.GET_TS256(X, Y: Integer): TColor32; var Width256, Height256: Integer; begin if (X >= F256ClipRect.Left) and (Y >= F256ClipRect.Top) then begin Width256 := (FClipRect.Right - 1) shl 8; Height256 := (FClipRect.Bottom - 1) shl 8; if (X < Width256) and (Y < Height256) then Result := GET_T256(X,Y) else if (X = Width256) and (Y <= Height256) then // We're exactly on the right border: no need to interpolate. Result := Pixel[FClipRect.Right - 1, Y shr 8] else if (X <= Width256) and (Y = Height256) then // We're exactly on the bottom border: no need to interpolate. Result := Pixel[X shr 8, FClipRect.Bottom - 1] else Result := FOuterColor; end else Result := FOuterColor; end; function TCustomBitmap32.GetPixelF(X, Y: Single): TColor32; begin Result := GET_T256(Round(X * 256), Round(Y * 256)); {$IFNDEF OMIT_MMX} EMMS; {$ENDIF} end; function TCustomBitmap32.GetPixelFS(X, Y: Single): TColor32; begin Result := GET_TS256(Round(X * 256), Round(Y * 256)); {$IFNDEF OMIT_MMX} EMMS; {$ENDIF} end; function TCustomBitmap32.GetPixelFW(X, Y: Single): TColor32; begin Result := GetPixelXW(Round(X * FixedOne), Round(Y * FixedOne)); {$IFNDEF OMIT_MMX} EMMS; {$ENDIF} end; function TCustomBitmap32.GetPixelX(X, Y: TFixed): TColor32; begin X := (X + $7F) shr 8; Y := (Y + $7F) shr 8; Result := GET_T256(X, Y); {$IFNDEF OMIT_MMX} EMMS; {$ENDIF} end; function TCustomBitmap32.GetPixelXS(X, Y: TFixed): TColor32; {$IFDEF PUREPASCAL} begin X := (X + $7F) div 256; Y := (Y + $7F) div 256; Result := GET_TS256(X, Y); EMMS; {$ELSE} asm {$IFDEF TARGET_x64} PUSH RBP SUB RSP,$30 {$ENDIF} ADD X, $7F ADD Y, $7F SAR X, 8 SAR Y, 8 CALL TCustomBitmap32.GET_TS256 {$IFNDEF OMIT_MMX} CMP MMX_ACTIVE.Integer, $00 JZ @Exit DB $0F, $77 /// EMMS @Exit: {$ENDIF} {$IFDEF TARGET_x64} LEA RSP,[RBP+$30] POP RBP {$ENDIF} {$ENDIF} end; function TCustomBitmap32.GetPixelFR(X, Y: Single): TColor32; begin Result := FResampler.GetSampleFloat(X, Y); end; function TCustomBitmap32.GetPixelXR(X, Y: TFixed): TColor32; begin Result := FResampler.GetSampleFixed(X, Y); end; function TCustomBitmap32.GetPixelW(X, Y: Integer): TColor32; begin with FClipRect do Result := Bits[FWidth * WrapProcVert(Y, Top, Bottom - 1) + WrapProcHorz(X, Left, Right - 1)]; end; procedure TCustomBitmap32.SetPixelW(X, Y: Integer; Value: TColor32); begin with FClipRect do Bits[FWidth * WrapProcVert(Y, Top, Bottom - 1) + WrapProcHorz(X, Left, Right - 1)] := Value; end; function TCustomBitmap32.GetPixelXW(X, Y: TFixed): TColor32; var X1, X2, Y1, Y2 :Integer; W: Integer; begin X2 := TFixedRec(X).Int; Y2 := TFixedRec(Y).Int; with FClipRect do begin W := Right - 1; X1 := WrapProcHorz(X2, Left, W); X2 := WrapProcHorz(X2 + 1, Left, W); W := Bottom - 1; Y1 := WrapProcVert(Y2, Top, W) * Width; Y2 := WrapProcVert(Y2 + 1, Top, W) * Width; end; W := WordRec(TFixedRec(X).Frac).Hi; Result := CombineReg(CombineReg(Bits[X2 + Y2], Bits[X1 + Y2], W), CombineReg(Bits[X2 + Y1], Bits[X1 + Y1], W), WordRec(TFixedRec(Y).Frac).Hi); EMMS; end; class function TCustomBitmap32.GetPlatformBackendClass: TCustomBackendClass; begin Result := TMemoryBackend; end; procedure TCustomBitmap32.SetPixelXW(X, Y: TFixed; Value: TColor32); begin {$IFDEF USENATIVECODE} X := (X + $7F) div 256; Y := (Y + $7F) div 256; {$ELSE} asm ADD X, $7F ADD Y, $7F SAR X, 8 SAR Y, 8 end; {$ENDIF} with F256ClipRect do SET_T256(WrapProcHorz(X, Left, Right - 128), WrapProcVert(Y, Top, Bottom - 128), Value); EMMS; end; procedure TCustomBitmap32.SetStipple(NewStipple: TArrayOfColor32); begin FStippleCounter := 0; FStipplePattern := Copy(NewStipple, 0, Length(NewStipple)); end; procedure TCustomBitmap32.SetStipple(NewStipple: array of TColor32); var L: Integer; begin FStippleCounter := 0; L := High(NewStipple) + 1; SetLength(FStipplePattern, L); MoveLongword(NewStipple[0], FStipplePattern[0], L); end; procedure TCustomBitmap32.AdvanceStippleCounter(LengthPixels: Single); var L: Integer; Delta: Single; begin L := Length(FStipplePattern); Delta := LengthPixels * FStippleStep; if (L = 0) or (Delta = 0) then Exit; FStippleCounter := FStippleCounter + Delta; FStippleCounter := FStippleCounter - Floor(FStippleCounter / L) * L; end; function TCustomBitmap32.GetStippleColor: TColor32; var L: Integer; NextIndex, PrevIndex: Integer; PrevWeight: Integer; begin L := Length(FStipplePattern); if L = 0 then begin // no pattern defined, just return something and exit Result := clBlack32; Exit; end; FStippleCounter := Wrap(FStippleCounter, L); {$IFDEF FPC} PrevIndex := Trunc(FStippleCounter); {$ELSE} PrevIndex := Round(FStippleCounter - 0.5); {$ENDIF} PrevWeight := $FF - Round($FF * (FStippleCounter - PrevIndex)); if PrevIndex < 0 then FStippleCounter := L - 1; NextIndex := PrevIndex + 1; if NextIndex >= L then NextIndex := 0; if PrevWeight = $FF then Result := FStipplePattern[PrevIndex] else begin Result := CombineReg( FStipplePattern[PrevIndex], FStipplePattern[NextIndex], PrevWeight); EMMS; end; FStippleCounter := FStippleCounter + FStippleStep; end; procedure TCustomBitmap32.HorzLine(X1, Y, X2: Integer; Value: TColor32); begin FillLongword(Bits[X1 + Y * Width], X2 - X1 + 1, Value); end; procedure TCustomBitmap32.HorzLineS(X1, Y, X2: Integer; Value: TColor32); begin if FMeasuringMode then Changed(MakeRect(X1, Y, X2, Y + 1)) else if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) and TestClip(X1, X2, FClipRect.Left, FClipRect.Right) then begin HorzLine(X1, Y, X2, Value); Changed(MakeRect(X1, Y, X2, Y + 1)); end; end; procedure TCustomBitmap32.HorzLineT(X1, Y, X2: Integer; Value: TColor32); var i: Integer; P: PColor32; BlendMem: TBlendMem; begin if X2 < X1 then Exit; P := PixelPtr[X1, Y]; BlendMem := TBlendMem(BlendProc); for i := X1 to X2 do begin BlendMem(Value, P^); Inc(P); end; EMMS; end; procedure TCustomBitmap32.HorzLineTS(X1, Y, X2: Integer; Value: TColor32); begin if FMeasuringMode then Changed(MakeRect(X1, Y, X2, Y + 1)) else if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) and TestClip(X1, X2, FClipRect.Left, FClipRect.Right) then begin HorzLineT(X1, Y, X2, Value); Changed(MakeRect(X1, Y, X2, Y + 1)); end; end; procedure TCustomBitmap32.HorzLineTSP(X1, Y, X2: Integer); var I, N: Integer; begin if FMeasuringMode then Changed(MakeRect(X1, Y, X2, Y + 1)) else begin if Empty then Exit; if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then begin if ((X1 < FClipRect.Left) and (X2 < FClipRect.Left)) or ((X1 >= FClipRect.Right) and (X2 >= FClipRect.Right)) then begin AdvanceStippleCounter(Abs(X2 - X1) + 1); Exit; end; if X1 < FClipRect.Left then begin AdvanceStippleCounter(FClipRect.Left - X1); X1 := FClipRect.Left; end else if X1 >= FClipRect.Right then begin AdvanceStippleCounter(X1 - (FClipRect.Right - 1)); X1 := FClipRect.Right - 1; end; N := 0; if X2 < FClipRect.Left then begin N := FClipRect.Left - X2; X2 := FClipRect.Left; end else if X2 >= FClipRect.Right then begin N := X2 - (FClipRect.Right - 1); X2 := FClipRect.Right - 1; end; if X2 >= X1 then for I := X1 to X2 do SetPixelT(I, Y, GetStippleColor) else for I := X1 downto X2 do SetPixelT(I, Y, GetStippleColor); Changed(MakeRect(X1, Y, X2, Y + 1)); if N > 0 then AdvanceStippleCounter(N); end else AdvanceStippleCounter(Abs(X2 - X1) + 1); end; end; procedure TCustomBitmap32.HorzLineX(X1, Y, X2: TFixed; Value: TColor32); //Author: Michael Hansen var I: Integer; ChangedRect: TFixedRect; X1F, X2F, YF, Count: Integer; Wx1, Wx2, Wy, Wt: TColor32; PDst: PColor32; begin if X1 > X2 then Swap(X1, X2); ChangedRect := FixedRect(X1, Y, X2, Y + 1); try X1F := X1 shr 16; X2F := X2 shr 16; YF := Y shr 16; PDst := PixelPtr[X1F, YF]; Wy := Y and $ffff xor $ffff; Wx1 := X1 and $ffff xor $ffff; Wx2 := X2 and $ffff; Count := X2F - X1F - 1; if Wy > 0 then begin CombineMem(Value, PDst^, GAMMA_TABLE[(Wy * Wx1) shr 24]); Wt := GAMMA_TABLE[Wy shr 8]; Inc(PDst); for I := 0 to Count - 1 do begin CombineMem(Value, PDst^, Wt); Inc(PDst); end; CombineMem(Value, PDst^, GAMMA_TABLE[(Wy * Wx2) shr 24]); end; PDst := PixelPtr[X1F, YF + 1]; Wy := Wy xor $ffff; if Wy > 0 then begin CombineMem(Value, PDst^, GAMMA_TABLE[(Wy * Wx1) shr 24]); Inc(PDst); Wt := GAMMA_TABLE[Wy shr 8]; for I := 0 to Count - 1 do begin CombineMem(Value, PDst^, Wt); Inc(PDst); end; CombineMem(Value, PDst^, GAMMA_TABLE[(Wy * Wx2) shr 24]); end; finally EMMS; Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2); end; end; procedure TCustomBitmap32.HorzLineXS(X1, Y, X2: TFixed; Value: TColor32); //author: Michael Hansen var ChangedRect: TFixedRect; begin if X1 > X2 then Swap(X1, X2); ChangedRect := FixedRect(X1, Y, X2, Y + 1); if not FMeasuringMode then begin X1 := Constrain(X1, FFixedClipRect.Left, FFixedClipRect.Right); X2 := Constrain(X2, FFixedClipRect.Left, FFixedClipRect.Right); if (Abs(X2 - X1) > FIXEDONE) and InRange(Y, FFixedClipRect.Top, FFixedClipRect.Bottom - FIXEDONE) then HorzLineX(X1, Y, X2, Value) else LineXS(X1, Y, X2, Y, Value); end; Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2); end; procedure TCustomBitmap32.VertLine(X, Y1, Y2: Integer; Value: TColor32); var I, NH, NL: Integer; P: PColor32; begin if Y2 < Y1 then Exit; P := PixelPtr[X, Y1]; I := Y2 - Y1 + 1; NH := I shr 2; NL := I and $03; for I := 0 to NH - 1 do begin P^ := Value; Inc(P, Width); P^ := Value; Inc(P, Width); P^ := Value; Inc(P, Width); P^ := Value; Inc(P, Width); end; for I := 0 to NL - 1 do begin P^ := Value; Inc(P, Width); end; end; procedure TCustomBitmap32.VertLineS(X, Y1, Y2: Integer; Value: TColor32); begin if FMeasuringMode then Changed(MakeRect(X, Y1, X + 1, Y2)) else if (X >= FClipRect.Left) and (X < FClipRect.Right) and TestClip(Y1, Y2, FClipRect.Top, FClipRect.Bottom) then begin VertLine(X, Y1, Y2, Value); Changed(MakeRect(X, Y1, X + 1, Y2)); end; end; procedure TCustomBitmap32.VertLineT(X, Y1, Y2: Integer; Value: TColor32); var i: Integer; P: PColor32; BlendMem: TBlendMem; begin P := PixelPtr[X, Y1]; BlendMem := TBlendMem(BlendProc); for i := Y1 to Y2 do begin BlendMem(Value, P^); Inc(P, Width); end; EMMS; end; procedure TCustomBitmap32.VertLineTS(X, Y1, Y2: Integer; Value: TColor32); begin if FMeasuringMode then Changed(MakeRect(X, Y1, X + 1, Y2)) else if (X >= FClipRect.Left) and (X < FClipRect.Right) and TestClip(Y1, Y2, FClipRect.Top, FClipRect.Bottom) then begin VertLineT(X, Y1, Y2, Value); Changed(MakeRect(X, Y1, X + 1, Y2)); end; end; procedure TCustomBitmap32.VertLineTSP(X, Y1, Y2: Integer); var I, N: Integer; begin if FMeasuringMode then Changed(MakeRect(X, Y1, X + 1, Y2)) else begin if Empty then Exit; if (X >= FClipRect.Left) and (X < FClipRect.Right) then begin if ((Y1 < FClipRect.Top) and (Y2 < FClipRect.Top)) or ((Y1 >= FClipRect.Bottom) and (Y2 >= FClipRect.Bottom)) then begin AdvanceStippleCounter(Abs(Y2 - Y1) + 1); Exit; end; if Y1 < FClipRect.Top then begin AdvanceStippleCounter(FClipRect.Top - Y1); Y1 := FClipRect.Top; end else if Y1 >= FClipRect.Bottom then begin AdvanceStippleCounter(Y1 - (FClipRect.Bottom - 1)); Y1 := FClipRect.Bottom - 1; end; N := 0; if Y2 < FClipRect.Top then begin N := FClipRect.Top - Y2; Y2 := FClipRect.Top; end else if Y2 >= FClipRect.Bottom then begin N := Y2 - (FClipRect.Bottom - 1); Y2 := FClipRect.Bottom - 1; end; if Y2 >= Y1 then for I := Y1 to Y2 do SetPixelT(X, I, GetStippleColor) else for I := Y1 downto Y2 do SetPixelT(X, I, GetStippleColor); Changed(MakeRect(X, Y1, X + 1, Y2)); if N > 0 then AdvanceStippleCounter(N); end else AdvanceStippleCounter(Abs(Y2 - Y1) + 1); end; end; procedure TCustomBitmap32.VertLineX(X, Y1, Y2: TFixed; Value: TColor32); //Author: Michael Hansen var I: Integer; ChangedRect: TFixedRect; Y1F, Y2F, XF, Count: Integer; Wy1, Wy2, Wx, Wt: TColor32; PDst: PColor32; begin if Y1 > Y2 then Swap(Y1, Y2); ChangedRect := FixedRect(X, Y1, X + 1, Y2); try Y1F := Y1 shr 16; Y2F := Y2 shr 16; XF := X shr 16; PDst := PixelPtr[XF, Y1F]; Wx := X and $ffff xor $ffff; Wy1 := Y1 and $ffff xor $ffff; Wy2 := Y2 and $ffff; Count := Y2F - Y1F - 1; if Wx > 0 then begin CombineMem(Value, PDst^, GAMMA_TABLE[(Wx * Wy1) shr 24]); Wt := GAMMA_TABLE[Wx shr 8]; Inc(PDst, FWidth); for I := 0 to Count - 1 do begin CombineMem(Value, PDst^, Wt); Inc(PDst, FWidth); end; CombineMem(Value, PDst^, GAMMA_TABLE[(Wx * Wy2) shr 24]); end; PDst := PixelPtr[XF + 1, Y1F]; Wx := Wx xor $ffff; if Wx > 0 then begin CombineMem(Value, PDst^, GAMMA_TABLE[(Wx * Wy1) shr 24]); Inc(PDst, FWidth); Wt := GAMMA_TABLE[Wx shr 8]; for I := 0 to Count - 1 do begin CombineMem(Value, PDst^, Wt); Inc(PDst, FWidth); end; CombineMem(Value, PDst^, GAMMA_TABLE[(Wx * Wy2) shr 24]); end; finally EMMS; Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2); end; end; procedure TCustomBitmap32.VertLineXS(X, Y1, Y2: TFixed; Value: TColor32); //author: Michael Hansen var ChangedRect: TFixedRect; begin if Y1 > Y2 then Swap(Y1, Y2); ChangedRect := FixedRect(X, Y1, X + 1, Y2); if not FMeasuringMode then begin Y1 := Constrain(Y1, FFixedClipRect.Top, FFixedClipRect.Bottom - FIXEDONE); Y2 := Constrain(Y2, FFixedClipRect.Top, FFixedClipRect.Bottom - FIXEDONE); if (Abs(Y2 - Y1) > FIXEDONE) and InRange(X, FFixedClipRect.Left, FFixedClipRect.Right - FIXEDONE) then VertLineX(X, Y1, Y2, Value) else LineXS(X, Y1, X, Y2, Value); end; Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2); end; procedure TCustomBitmap32.Line(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean); var Dy, Dx, Sy, Sx, I, Delta: Integer; P: PColor32; ChangedRect: TRect; begin ChangedRect := MakeRect(X1, Y1, X2, Y2); try Dx := X2 - X1; Dy := Y2 - Y1; if Dx > 0 then Sx := 1 else if Dx < 0 then begin Dx := -Dx; Sx := -1; end else // Dx = 0 begin if Dy > 0 then VertLine(X1, Y1, Y2 - 1, Value) else if Dy < 0 then VertLine(X1, Y2 + 1, Y1, Value); if L then Pixel[X2, Y2] := Value; Exit; end; if Dy > 0 then Sy := 1 else if Dy < 0 then begin Dy := -Dy; Sy := -1; end else // Dy = 0 begin if X2 > X1 then HorzLine(X1, Y1, X2 - 1, Value) else HorzLine(X2 + 1, Y1, X1, Value); if L then Pixel[X2, Y2] := Value; Exit; end; P := PixelPtr[X1, Y1]; Sy := Sy * Width; if Dx > Dy then begin Delta := Dx shr 1; for I := 0 to Dx - 1 do begin P^ := Value; Inc(P, Sx); Inc(Delta, Dy); if Delta >= Dx then begin Inc(P, Sy); Dec(Delta, Dx); end; end; end else // Dx < Dy begin Delta := Dy shr 1; for I := 0 to Dy - 1 do begin P^ := Value; Inc(P, Sy); Inc(Delta, Dx); if Delta >= Dy then begin Inc(P, Sx); Dec(Delta, Dy); end; end; end; if L then P^ := Value; finally Changed(ChangedRect, AREAINFO_LINE + 2); end; end; procedure TCustomBitmap32.LineS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean); var Dx2, Dy2,Cx1, Cx2, Cy1, Cy2, PI, Sx, Sy, Dx, Dy, xd, yd, rem, term, e: Integer; OC: Int64; Swapped, CheckAux: Boolean; P: PColor32; ChangedRect: TRect; begin ChangedRect := MakeRect(X1, Y1, X2, Y2); if not FMeasuringMode then begin Dx := X2 - X1; Dy := Y2 - Y1; // check for trivial cases... if Dx = 0 then // vertical line? begin if Dy > 0 then VertLineS(X1, Y1, Y2 - 1, Value) else if Dy < 0 then VertLineS(X1, Y2 + 1, Y1, Value); if L then PixelS[X2, Y2] := Value; Changed; Exit; end else if Dy = 0 then // horizontal line? begin if Dx > 0 then HorzLineS(X1, Y1, X2 - 1, Value) else if Dx < 0 then HorzLineS(X2 + 1, Y1, X1, Value); if L then PixelS[X2, Y2] := Value; Changed; Exit; end; Cx1 := FClipRect.Left; Cx2 := FClipRect.Right - 1; Cy1 := FClipRect.Top; Cy2 := FClipRect.Bottom - 1; if Dx > 0 then begin if (X1 > Cx2) or (X2 < Cx1) then Exit; // segment not visible Sx := 1; end else begin if (X2 > Cx2) or (X1 < Cx1) then Exit; // segment not visible Sx := -1; X1 := -X1; X2 := -X2; Dx := -Dx; Cx1 := -Cx1; Cx2 := -Cx2; Swap(Cx1, Cx2); end; if Dy > 0 then begin if (Y1 > Cy2) or (Y2 < Cy1) then Exit; // segment not visible Sy := 1; end else begin if (Y2 > Cy2) or (Y1 < Cy1) then Exit; // segment not visible Sy := -1; Y1 := -Y1; Y2 := -Y2; Dy := -Dy; Cy1 := -Cy1; Cy2 := -Cy2; Swap(Cy1, Cy2); end; if Dx < Dy then begin Swapped := True; Swap(X1, Y1); Swap(X2, Y2); Swap(Dx, Dy); Swap(Cx1, Cy1); Swap(Cx2, Cy2); Swap(Sx, Sy); end else Swapped := False; // Bresenham's set up: Dx2 := Dx shl 1; Dy2 := Dy shl 1; xd := X1; yd := Y1; e := Dy2 - Dx; term := X2; CheckAux := True; // clipping rect horizontal entry if Y1 < Cy1 then begin OC := Int64(Dx2) * (Cy1 - Y1) - Dx; Inc(xd, OC div Dy2); rem := OC mod Dy2; if xd > Cx2 then Exit; if xd >= Cx1 then begin yd := Cy1; Dec(e, rem + Dx); if rem > 0 then begin Inc(xd); Inc(e, Dy2); end; CheckAux := False; // to avoid ugly goto we set this to omit the next check end; end; // clipping rect vertical entry if CheckAux and (X1 < Cx1) then begin OC := Int64(Dy2) * (Cx1 - X1); Inc(yd, OC div Dx2); rem := OC mod Dx2; if (yd > Cy2) or (yd = Cy2) and (rem >= Dx) then Exit; xd := Cx1; Inc(e, rem); if (rem >= Dx) then begin Inc(yd); Dec(e, Dx2); end; end; // set auxiliary var to indicate that term is not clipped, since // term still has the unclipped value assigned at setup. CheckAux := False; // is the segment exiting the clipping rect? if Y2 > Cy2 then begin OC := Int64(Dx2) * (Cy2 - Y1) + Dx; term := X1 + OC div Dy2; rem := OC mod Dy2; if rem = 0 then Dec(term); CheckAux := True; // set auxiliary var to indicate that term is clipped end; if term > Cx2 then begin term := Cx2; CheckAux := True; // set auxiliary var to indicate that term is clipped end; Inc(term); if Sy = -1 then yd := -yd; if Sx = -1 then begin xd := -xd; term := -term; end; Dec(Dx2, Dy2); if Swapped then begin PI := Sx * Width; P := @Bits[yd + xd * Width]; end else begin PI := Sx; Sy := Sy * Width; P := @Bits[xd + yd * Width]; end; // do we need to skip the last pixel of the line and is term not clipped? if not(L or CheckAux) then begin if xd < term then Dec(term) else Inc(term); end; while xd <> term do begin Inc(xd, Sx); P^ := Value; Inc(P, PI); if e >= 0 then begin Inc(P, Sy); Dec(e, Dx2); end else Inc(e, Dy2); end; end; Changed(ChangedRect, AREAINFO_LINE + 2); end; procedure TCustomBitmap32.LineT(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean); var Dy, Dx, Sy, Sx, I, Delta: Integer; P: PColor32; BlendMem: TBlendMem; ChangedRect: TRect; begin ChangedRect := MakeRect(X1, Y1, X2, Y2); try Dx := X2 - X1; Dy := Y2 - Y1; if Dx > 0 then Sx := 1 else if Dx < 0 then begin Dx := -Dx; Sx := -1; end else // Dx = 0 begin if Dy > 0 then VertLineT(X1, Y1, Y2 - 1, Value) else if Dy < 0 then VertLineT(X1, Y2 + 1, Y1, Value); if L then SetPixelT(X2, Y2, Value); Exit; end; if Dy > 0 then Sy := 1 else if Dy < 0 then begin Dy := -Dy; Sy := -1; end else // Dy = 0 begin if X2 > X1 then HorzLineT(X1, Y1, X2 - 1, Value) else HorzLineT(X2 + 1, Y1, X1, Value); if L then SetPixelT(X2, Y2, Value); Exit; end; P := PixelPtr[X1, Y1]; Sy := Sy * Width; try BlendMem := TBlendMem(BlendProc); if Dx > Dy then begin Delta := Dx shr 1; for I := 0 to Dx - 1 do begin BlendMem(Value, P^); Inc(P, Sx); Inc(Delta, Dy); if Delta >= Dx then begin Inc(P, Sy); Dec(Delta, Dx); end; end; end else // Dx < Dy begin Delta := Dy shr 1; for I := 0 to Dy - 1 do begin BlendMem(Value, P^); Inc(P, Sy); Inc(Delta, Dx); if Delta >= Dy then begin Inc(P, Sx); Dec(Delta, Dy); end; end; end; if L then BlendMem(Value, P^); finally EMMS; end; finally Changed(ChangedRect, AREAINFO_LINE + 2); end; end; procedure TCustomBitmap32.LineTS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean); var Cx1, Cx2, Cy1, Cy2, PI, Sx, Sy, Dx, Dy, xd, yd, Dx2, Dy2, rem, term, e: Integer; OC: Int64; Swapped, CheckAux: Boolean; P: PColor32; BlendMem: TBlendMem; ChangedRect: TRect; begin ChangedRect := MakeRect(X1, Y1, X2, Y2); if not FMeasuringMode then begin Dx := X2 - X1; Dy := Y2 - Y1; // check for trivial cases... if Dx = 0 then // vertical line? begin if Dy > 0 then VertLineTS(X1, Y1, Y2 - 1, Value) else if Dy < 0 then VertLineTS(X1, Y2 + 1, Y1, Value); if L then SetPixelTS(X2, Y2, Value); Exit; end else if Dy = 0 then // horizontal line? begin if Dx > 0 then HorzLineTS(X1, Y1, X2 - 1, Value) else if Dx < 0 then HorzLineTS(X2 + 1, Y1, X1, Value); if L then SetPixelTS(X2, Y2, Value); Exit; end; Cx1 := FClipRect.Left; Cx2 := FClipRect.Right - 1; Cy1 := FClipRect.Top; Cy2 := FClipRect.Bottom - 1; if Dx > 0 then begin if (X1 > Cx2) or (X2 < Cx1) then Exit; // segment not visible Sx := 1; end else begin if (X2 > Cx2) or (X1 < Cx1) then Exit; // segment not visible Sx := -1; X1 := -X1; X2 := -X2; Dx := -Dx; Cx1 := -Cx1; Cx2 := -Cx2; Swap(Cx1, Cx2); end; if Dy > 0 then begin if (Y1 > Cy2) or (Y2 < Cy1) then Exit; // segment not visible Sy := 1; end else begin if (Y2 > Cy2) or (Y1 < Cy1) then Exit; // segment not visible Sy := -1; Y1 := -Y1; Y2 := -Y2; Dy := -Dy; Cy1 := -Cy1; Cy2 := -Cy2; Swap(Cy1, Cy2); end; if Dx < Dy then begin Swapped := True; Swap(X1, Y1); Swap(X2, Y2); Swap(Dx, Dy); Swap(Cx1, Cy1); Swap(Cx2, Cy2); Swap(Sx, Sy); end else Swapped := False; // Bresenham's set up: Dx2 := Dx shl 1; Dy2 := Dy shl 1; xd := X1; yd := Y1; e := Dy2 - Dx; term := X2; CheckAux := True; // clipping rect horizontal entry if Y1 < Cy1 then begin OC := Int64(Dx2) * (Cy1 - Y1) - Dx; Inc(xd, OC div Dy2); rem := OC mod Dy2; if xd > Cx2 then Exit; if xd >= Cx1 then begin yd := Cy1; Dec(e, rem + Dx); if rem > 0 then begin Inc(xd); Inc(e, Dy2); end; CheckAux := False; // to avoid ugly goto we set this to omit the next check end; end; // clipping rect vertical entry if CheckAux and (X1 < Cx1) then begin OC := Int64(Dy2) * (Cx1 - X1); Inc(yd, OC div Dx2); rem := OC mod Dx2; if (yd > Cy2) or (yd = Cy2) and (rem >= Dx) then Exit; xd := Cx1; Inc(e, rem); if (rem >= Dx) then begin Inc(yd); Dec(e, Dx2); end; end; // set auxiliary var to indicate that term is not clipped, since // term still has the unclipped value assigned at setup. CheckAux := False; // is the segment exiting the clipping rect? if Y2 > Cy2 then begin OC := Int64(Dx2) * (Cy2 - Y1) + Dx; term := X1 + OC div Dy2; rem := OC mod Dy2; if rem = 0 then Dec(term); CheckAux := True; // set auxiliary var to indicate that term is clipped end; if term > Cx2 then begin term := Cx2; CheckAux := True; // set auxiliary var to indicate that term is clipped end; Inc(term); if Sy = -1 then yd := -yd; if Sx = -1 then begin xd := -xd; term := -term; end; Dec(Dx2, Dy2); if Swapped then begin PI := Sx * Width; P := @Bits[yd + xd * Width]; end else begin PI := Sx; Sy := Sy * Width; P := @Bits[xd + yd * Width]; end; // do we need to skip the last pixel of the line and is term not clipped? if not(L or CheckAux) then begin if xd < term then Dec(term) else Inc(term); end; try BlendMem := BLEND_MEM[FCombineMode]^; while xd <> term do begin Inc(xd, Sx); BlendMem(Value, P^); Inc(P, PI); if e >= 0 then begin Inc(P, Sy); Dec(e, Dx2); end else Inc(e, Dy2); end; finally EMMS; end; end; Changed(ChangedRect, AREAINFO_LINE + 2); end; procedure TCustomBitmap32.LineX(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean); var n, i: Integer; nx, ny, hyp, hypl: Integer; A: TColor32; h: Single; ChangedRect: TFixedRect; begin ChangedRect := FixedRect(X1, Y1, X2, Y2); try nx := X2 - X1; ny := Y2 - Y1; Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127); hyp := Hypot(nx, ny); hypl := hyp + (Integer(L) * FixedOne); if (hypl < 256) then Exit; n := hypl shr 16; if n > 0 then begin h := 65536 / hyp; nx := Round(nx * h); ny := Round(ny * h); for i := 0 to n - 1 do begin SET_T256(X1 shr 8, Y1 shr 8, Value); Inc(X1, nx); Inc(Y1, ny); end; end; A := Value shr 24; hyp := hypl - n shl 16; A := A * Cardinal(hyp) shl 8 and $FF000000; SET_T256((X1 + X2 - nx) shr 9, (Y1 + Y2 - ny) shr 9, Value and $00FFFFFF + A); finally EMMS; Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2); end; end; procedure TCustomBitmap32.LineF(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean); begin LineX(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), Value, L); end; procedure TCustomBitmap32.LineXS(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean); var n, i: Integer; ex, ey, nx, ny, hyp, hypl: Integer; A: TColor32; h: Single; ChangedRect: TFixedRect; begin ChangedRect := FixedRect(X1, Y1, X2, Y2); if not FMeasuringMode then begin ex := X2; ey := Y2; // Check for visibility and clip the coordinates if not ClipLine(Integer(X1), Integer(Y1), Integer(X2), Integer(Y2), FFixedClipRect.Left - $10000, FFixedClipRect.Top - $10000, FFixedClipRect.Right, FFixedClipRect.Bottom) then Exit; { TODO : Handle L on clipping here... } if (ex <> X2) or (ey <> Y2) then L := True; // Check if it lies entirely in the bitmap area. Even after clipping // some pixels may lie outside the bitmap due to antialiasing if (X1 > FFixedClipRect.Left) and (X1 < FFixedClipRect.Right - $20000) and (Y1 > FFixedClipRect.Top) and (Y1 < FFixedClipRect.Bottom - $20000) and (X2 > FFixedClipRect.Left) and (X2 < FFixedClipRect.Right - $20000) and (Y2 > FFixedClipRect.Top) and (Y2 < FFixedClipRect.Bottom - $20000) then begin LineX(X1, Y1, X2, Y2, Value, L); Exit; end; // if we are still here, it means that the line touches one or several bitmap // boundaries. Use the safe version of antialiased pixel routine try nx := X2 - X1; ny := Y2 - Y1; Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127); hyp := Hypot(nx, ny); if hyp = 0 then Exit; hypl := hyp + (Integer(L) * FixedOne); if hypl < 256 then Exit; n := hypl shr 16; if n > 0 then begin h := 65536 / hyp; nx := Round(nx * h); ny := Round(ny * h); for i := 0 to n - 1 do begin SET_TS256(SAR_8(X1), SAR_8(Y1), Value); X1 := X1 + nx; Y1 := Y1 + ny; end; end; A := Value shr 24; hyp := hypl - n shl 16; A := A * Cardinal(hyp) shl 8 and $FF000000; SET_TS256(SAR_9(X1 + X2 - nx), SAR_9(Y1 + Y2 - ny), Value and $00FFFFFF + A); finally EMMS; end; end; Changed(MakeRect(ChangedRect), AREAINFO_LINE + 2); end; procedure TCustomBitmap32.LineFS(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean); begin LineXS(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), Value, L); end; procedure TCustomBitmap32.LineXP(X1, Y1, X2, Y2: TFixed; L: Boolean); var n, i: Integer; nx, ny, hyp, hypl: Integer; A, C: TColor32; ChangedRect: TRect; begin ChangedRect := MakeRect(FixedRect(X1, Y1, X2, Y2)); try nx := X2 - X1; ny := Y2 - Y1; Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127); hyp := Hypot(nx, ny); hypl := hyp + (Integer(L) * FixedOne); if hypl < 256 then Exit; n := hypl shr 16; if n > 0 then begin nx := Round(nx / hyp * 65536); ny := Round(ny / hyp * 65536); for i := 0 to n - 1 do begin C := GetStippleColor; SET_T256(X1 shr 8, Y1 shr 8, C); EMMS; X1 := X1 + nx; Y1 := Y1 + ny; end; end; C := GetStippleColor; A := C shr 24; hyp := hypl - n shl 16; A := A * Longword(hyp) shl 8 and $FF000000; SET_T256((X1 + X2 - nx) shr 9, (Y1 + Y2 - ny) shr 9, C and $00FFFFFF + A); EMMS; finally Changed(ChangedRect, AREAINFO_LINE + 2); end; end; procedure TCustomBitmap32.LineFP(X1, Y1, X2, Y2: Single; L: Boolean); begin LineXP(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), L); end; procedure TCustomBitmap32.LineXSP(X1, Y1, X2, Y2: TFixed; L: Boolean); const StippleInc: array [Boolean] of Single = (0, 1); var n, i: Integer; sx, sy, ex, ey, nx, ny, hyp, hypl: Integer; A, C: TColor32; ChangedRect: TRect; begin ChangedRect := MakeRect(FixedRect(X1, Y1, X2, Y2)); if not FMeasuringMode then begin sx := X1; sy := Y1; ex := X2; ey := Y2; // Check for visibility and clip the coordinates if not ClipLine(Integer(X1), Integer(Y1), Integer(X2), Integer(Y2), FFixedClipRect.Left - $10000, FFixedClipRect.Top - $10000, FFixedClipRect.Right, FFixedClipRect.Bottom) then begin AdvanceStippleCounter(GR32_Math.Hypot(Integer((X2 - X1) shr 16), Integer((Y2 - Y1) shr 16) - StippleInc[L])); Exit; end; if (ex <> X2) or (ey <> Y2) then L := True; // Check if it lies entirely in the bitmap area. Even after clipping // some pixels may lie outside the bitmap due to antialiasing if (X1 > FFixedClipRect.Left) and (X1 < FFixedClipRect.Right - $20000) and (Y1 > FFixedClipRect.Top) and (Y1 < FFixedClipRect.Bottom - $20000) and (X2 > FFixedClipRect.Left) and (X2 < FFixedClipRect.Right - $20000) and (Y2 > FFixedClipRect.Top) and (Y2 < FFixedClipRect.Bottom - $20000) then begin LineXP(X1, Y1, X2, Y2, L); Exit; end; if (sx <> X1) or (sy <> Y1) then AdvanceStippleCounter(GR32_Math.Hypot(Integer((X1 - sx) shr 16), Integer((Y1 - sy) shr 16))); // if we are still here, it means that the line touches one or several bitmap // boundaries. Use the safe version of antialiased pixel routine nx := X2 - X1; ny := Y2 - Y1; Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127); hyp := GR32_Math.Hypot(nx, ny); if hyp = 0 then Exit; hypl := hyp + (Integer(L) * FixedOne); if hypl < 256 then Exit; n := hypl shr 16; if n > 0 then begin nx := Round(nx / hyp * 65536); ny := Round(ny / hyp * 65536); for i := 0 to n - 1 do begin C := GetStippleColor; SET_TS256(SAR_8(X1), SAR_8(Y1), C); EMMS; X1 := X1 + nx; Y1 := Y1 + ny; end; end; C := GetStippleColor; A := C shr 24; hyp := hypl - n shl 16; A := A * Longword(hyp) shl 8 and $FF000000; SET_TS256(SAR_9(X1 + X2 - nx), SAR_9(Y1 + Y2 - ny), C and $00FFFFFF + A); EMMS; if (ex <> X2) or (ey <> Y2) then AdvanceStippleCounter(GR32_Math.Hypot(Integer((X2 - ex) shr 16), Integer((Y2 - ey) shr 16) - StippleInc[L])); end; Changed(ChangedRect, AREAINFO_LINE + 4); end; procedure TCustomBitmap32.LineFSP(X1, Y1, X2, Y2: Single; L: Boolean); begin LineXSP(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), L); end; procedure TCustomBitmap32.LineA(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean); var Dx, Dy, Sx, Sy, D: Integer; EC, EA: Word; CI: Byte; P: PColor32; BlendMemEx: TBlendMemEx; begin if (X1 = X2) or (Y1 = Y2) then begin LineT(X1, Y1, X2, Y2, Value, L); Exit; end; Dx := X2 - X1; Dy := Y2 - Y1; if Dx > 0 then Sx := 1 else begin Sx := -1; Dx := -Dx; end; if Dy > 0 then Sy := 1 else begin Sy := -1; Dy := -Dy; end; try EC := 0; BLEND_MEM[FCombineMode]^(Value, Bits[X1 + Y1 * Width]); BlendMemEx := BLEND_MEM_EX[FCombineMode]^; if Dy > Dx then begin EA := Dx shl 16 div Dy; if not L then Dec(Dy); while Dy > 0 do begin Dec(Dy); D := EC; Inc(EC, EA); if EC <= D then Inc(X1, Sx); Inc(Y1, Sy); CI := EC shr 8; P := @Bits[X1 + Y1 * Width]; BlendMemEx(Value, P^, GAMMA_TABLE[CI xor $FF]); Inc(P, Sx); BlendMemEx(Value, P^, GAMMA_TABLE[CI]); end; end else // DY <= DX begin EA := Dy shl 16 div Dx; if not L then Dec(Dx); while Dx > 0 do begin Dec(Dx); D := EC; Inc(EC, EA); if EC <= D then Inc(Y1, Sy); Inc(X1, Sx); CI := EC shr 8; P := @Bits[X1 + Y1 * Width]; BlendMemEx(Value, P^, GAMMA_TABLE[CI xor $FF]); if Sy = 1 then Inc(P, Width) else Dec(P, Width); BlendMemEx(Value, P^, GAMMA_TABLE[CI]); end; end; finally EMMS; Changed(MakeRect(X1, Y1, X2, Y2), AREAINFO_LINE + 2); end; end; procedure TCustomBitmap32.LineAS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean); var Cx1, Cx2, Cy1, Cy2, PI, Sx, Sy, Dx, Dy, xd, yd, rem, term, tmp: Integer; CheckVert, CornerAA, TermClipped: Boolean; D1, D2: PInteger; EC, EA, ED, D: Word; CI: Byte; P: PColor32; BlendMemEx: TBlendMemEx; ChangedRect: TRect; begin ChangedRect := MakeRect(X1, Y1, X2, Y2); if not FMeasuringMode then begin if (FClipRect.Right - FClipRect.Left = 0) or (FClipRect.Bottom - FClipRect.Top = 0) then Exit; Dx := X2 - X1; Dy := Y2 - Y1; // check for trivial cases... if Abs(Dx) = Abs(Dy) then // diagonal line? begin LineTS(X1, Y1, X2, Y2, Value, L); Exit; end else if Dx = 0 then // vertical line? begin if Dy > 0 then VertLineTS(X1, Y1, Y2 - 1, Value) else if Dy < 0 then VertLineTS(X1, Y2 + 1, Y1, Value); if L then SetPixelTS(X2, Y2, Value); Exit; end else if Dy = 0 then // horizontal line? begin if Dx > 0 then HorzLineTS(X1, Y1, X2 - 1, Value) else if Dx < 0 then HorzLineTS(X2 + 1, Y1, X1, Value); if L then SetPixelTS(X2, Y2, Value); Exit; end; Cx1 := FClipRect.Left; Cx2 := FClipRect.Right - 1; Cy1 := FClipRect.Top; Cy2 := FClipRect.Bottom - 1; if Dx > 0 then begin if (X1 > Cx2) or (X2 < Cx1) then Exit; // segment not visible Sx := 1; end else begin if (X2 > Cx2) or (X1 < Cx1) then Exit; // segment not visible Sx := -1; X1 := -X1; X2 := -X2; Dx := -Dx; Cx1 := -Cx1; Cx2 := -Cx2; Swap(Cx1, Cx2); end; if Dy > 0 then begin if (Y1 > Cy2) or (Y2 < Cy1) then Exit; // segment not visible Sy := 1; end else begin if (Y2 > Cy2) or (Y1 < Cy1) then Exit; // segment not visible Sy := -1; Y1 := -Y1; Y2 := -Y2; Dy := -Dy; Cy1 := -Cy1; Cy2 := -Cy2; Swap(Cy1, Cy2); end; if Dx < Dy then begin Swap(X1, Y1); Swap(X2, Y2); Swap(Dx, Dy); Swap(Cx1, Cy1); Swap(Cx2, Cy2); Swap(Sx, Sy); D1 := @yd; D2 := @xd; PI := Sy; end else begin D1 := @xd; D2 := @yd; PI := Sy * Width; end; rem := 0; EA := Dy shl 16 div Dx; EC := 0; xd := X1; yd := Y1; CheckVert := True; CornerAA := False; BlendMemEx := BLEND_MEM_EX[FCombineMode]^; // clipping rect horizontal entry if Y1 < Cy1 then begin tmp := (Cy1 - Y1) * 65536; rem := tmp - 65536; // rem := (Cy1 - Y1 - 1) * 65536; if tmp mod EA > 0 then tmp := tmp div EA + 1 else tmp := tmp div EA; xd := Math.Min(xd + tmp, X2 + 1); EC := tmp * EA; if rem mod EA > 0 then rem := rem div EA + 1 else rem := rem div EA; tmp := tmp - rem; // check whether the line is partly visible if xd > Cx2 then // do we need to draw an antialiased part on the corner of the clip rect? if xd <= Cx2 + tmp then CornerAA := True else Exit; if (xd {+ 1} >= Cx1) or CornerAA then begin yd := Cy1; rem := xd; // save old xd ED := EC - EA; term := SwapConstrain(xd - tmp, Cx1, Cx2); if CornerAA then begin Dec(ED, (xd - Cx2 - 1) * EA); xd := Cx2 + 1; end; // do we need to negate the vars? if Sy = -1 then yd := -yd; if Sx = -1 then begin xd := -xd; term := -term; end; // draw special case horizontal line entry (draw only last half of entering segment) try while xd <> term do begin Inc(xd, -Sx); BlendMemEx(Value, Bits[D1^ + D2^ * Width], GAMMA_TABLE[ED shr 8]); Dec(ED, EA); end; finally EMMS; end; if CornerAA then begin // we only needed to draw the visible antialiased part of the line, // everything else is outside of our cliprect, so exit now since // there is nothing more to paint... { TODO : Handle Changed here... } Changed; Exit; end; if Sy = -1 then yd := -yd; // negate back xd := rem; // restore old xd CheckVert := False; // to avoid ugly goto we set this to omit the next check end; end; // clipping rect vertical entry if CheckVert and (X1 < Cx1) then begin tmp := (Cx1 - X1) * EA; Inc(yd, tmp div 65536); EC := tmp; xd := Cx1; if (yd > Cy2) then Exit else if (yd = Cy2) then CornerAA := True; end; term := X2; TermClipped := False; CheckVert := False; // horizontal exit? if Y2 > Cy2 then begin tmp := (Cy2 - Y1) * 65536; term := X1 + tmp div EA; if not(tmp mod EA > 0) then Dec(Term); if term < Cx2 then begin rem := tmp + 65536; // was: rem := (Cy2 - Y1 + 1) * 65536; if rem mod EA > 0 then rem := X1 + rem div EA + 1 else rem := X1 + rem div EA; if rem > Cx2 then rem := Cx2; CheckVert := True; end; TermClipped := True; end; if term > Cx2 then begin term := Cx2; TermClipped := True; end; Inc(term); if Sy = -1 then yd := -yd; if Sx = -1 then begin xd := -xd; term := -term; rem := -rem; end; // draw line if not CornerAA then try // do we need to skip the last pixel of the line and is term not clipped? if not(L or TermClipped) and not CheckVert then begin if xd < term then Dec(term) else if xd > term then Inc(term); end; while xd <> term do begin CI := EC shr 8; P := @Bits[D1^ + D2^ * Width]; BlendMemEx(Value, P^, GAMMA_TABLE[CI xor $FF]); Inc(P, PI); BlendMemEx(Value, P^, GAMMA_TABLE[CI]); // check for overflow and jump to next line... D := EC; Inc(EC, EA); if EC <= D then Inc(yd, Sy); Inc(xd, Sx); end; finally EMMS; end; // draw special case horizontal line exit (draw only first half of exiting segment) if CheckVert then try while xd <> rem do begin BlendMemEx(Value, Bits[D1^ + D2^ * Width], GAMMA_TABLE[EC shr 8 xor $FF]); Inc(EC, EA); Inc(xd, Sx); end; finally EMMS; end; end; Changed(ChangedRect, AREAINFO_LINE + 2); end; procedure TCustomBitmap32.MoveTo(X, Y: Integer); begin RasterX := X; RasterY := Y; end; procedure TCustomBitmap32.LineToS(X, Y: Integer); begin LineS(RasterX, RasterY, X, Y, PenColor); RasterX := X; RasterY := Y; end; procedure TCustomBitmap32.LineToTS(X, Y: Integer); begin LineTS(RasterX, RasterY, X, Y, PenColor); RasterX := X; RasterY := Y; end; procedure TCustomBitmap32.LineToAS(X, Y: Integer); begin LineAS(RasterX, RasterY, X, Y, PenColor); RasterX := X; RasterY := Y; end; procedure TCustomBitmap32.MoveToX(X, Y: TFixed); begin RasterXF := X; RasterYF := Y; end; procedure TCustomBitmap32.MoveToF(X, Y: Single); begin RasterXF := Fixed(X); RasterYF := Fixed(Y); end; procedure TCustomBitmap32.LineToXS(X, Y: TFixed); begin LineXS(RasterXF, RasterYF, X, Y, PenColor); RasterXF := X; RasterYF := Y; end; procedure TCustomBitmap32.LineToFS(X, Y: Single); begin LineToXS(Fixed(X), Fixed(Y)); end; procedure TCustomBitmap32.LineToXSP(X, Y: TFixed); begin LineXSP(RasterXF, RasterYF, X, Y); RasterXF := X; RasterYF := Y; end; procedure TCustomBitmap32.LineToFSP(X, Y: Single); begin LineToXSP(Fixed(X), Fixed(Y)); end; procedure TCustomBitmap32.FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32); var j: Integer; P: PColor32Array; begin if Assigned(FBits) then for j := Y1 to Y2 - 1 do begin P := Pointer(@Bits[j * FWidth]); FillLongword(P[X1], X2 - X1, Value); end; Changed(MakeRect(X1, Y1, X2, Y2)); end; procedure TCustomBitmap32.FillRectS(X1, Y1, X2, Y2: Integer; Value: TColor32); begin if not FMeasuringMode and (X2 > X1) and (Y2 > Y1) and (X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and (X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then begin if X1 < FClipRect.Left then X1 := FClipRect.Left; if Y1 < FClipRect.Top then Y1 := FClipRect.Top; if X2 > FClipRect.Right then X2 := FClipRect.Right; if Y2 > FClipRect.Bottom then Y2 := FClipRect.Bottom; FillRect(X1, Y1, X2, Y2, Value); end; Changed(MakeRect(X1, Y1, X2, Y2)); end; procedure TCustomBitmap32.FillRectT(X1, Y1, X2, Y2: Integer; Value: TColor32); var i, j: Integer; P: PColor32; A: Integer; begin A := Value shr 24; if A = $FF then FillRect(X1, Y1, X2, Y2, Value) // calls Changed... else if A <> 0 then try Dec(Y2); Dec(X2); for j := Y1 to Y2 do begin P := GetPixelPtr(X1, j); if CombineMode = cmBlend then begin for i := X1 to X2 do begin CombineMem(Value, P^, A); Inc(P); end; end else begin for i := X1 to X2 do begin MergeMem(Value, P^); Inc(P); end; end; end; finally EMMS; Changed(MakeRect(X1, Y1, X2 + 1, Y2 + 1)); end; end; procedure TCustomBitmap32.FillRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32); begin if not FMeasuringMode and (X2 > X1) and (Y2 > Y1) and (X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and (X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then begin if X1 < FClipRect.Left then X1 := FClipRect.Left; if Y1 < FClipRect.Top then Y1 := FClipRect.Top; if X2 > FClipRect.Right then X2 := FClipRect.Right; if Y2 > FClipRect.Bottom then Y2 := FClipRect.Bottom; FillRectT(X1, Y1, X2, Y2, Value); end; Changed(MakeRect(X1, Y1, X2, Y2)); end; procedure TCustomBitmap32.FillRectS(const ARect: TRect; Value: TColor32); begin if FMeasuringMode then // shortcut... Changed(ARect) else with ARect do FillRectS(Left, Top, Right, Bottom, Value); end; procedure TCustomBitmap32.FillRectTS(const ARect: TRect; Value: TColor32); begin if FMeasuringMode then // shortcut... Changed(ARect) else with ARect do FillRectTS(Left, Top, Right, Bottom, Value); end; procedure TCustomBitmap32.FrameRectS(X1, Y1, X2, Y2: Integer; Value: TColor32); begin // measuring is handled in inner drawing operations... if (X2 > X1) and (Y2 > Y1) and (X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and (X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then begin Dec(Y2); Dec(X2); HorzLineS(X1, Y1, X2, Value); if Y2 > Y1 then HorzLineS(X1, Y2, X2, Value); if Y2 > Y1 + 1 then begin VertLineS(X1, Y1 + 1, Y2 - 1, Value); if X2 > X1 then VertLineS(X2, Y1 + 1, Y2 - 1, Value); end; end; end; procedure TCustomBitmap32.FrameRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32); begin // measuring is handled in inner drawing operations... if (X2 > X1) and (Y2 > Y1) and (X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and (X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then begin Dec(Y2); Dec(X2); HorzLineTS(X1, Y1, X2, Value); if Y2 > Y1 then HorzLineTS(X1, Y2, X2, Value); if Y2 > Y1 + 1 then begin VertLineTS(X1, Y1 + 1, Y2 - 1, Value); if X2 > X1 then VertLineTS(X2, Y1 + 1, Y2 - 1, Value); end; end; end; procedure TCustomBitmap32.FrameRectTSP(X1, Y1, X2, Y2: Integer); begin // measuring is handled in inner drawing operations... if (X2 > X1) and (Y2 > Y1) and (X1 < Width) and (Y1 < Height) and // don't check against ClipRect here (X2 > 0) and (Y2 > 0) then // due to StippleCounter begin Dec(X2); Dec(Y2); if X1 = X2 then if Y1 = Y2 then begin SetPixelT(X1, Y1, GetStippleColor); Changed(MakeRect(X1, Y1, X1 + 1, Y1 + 1)); end else VertLineTSP(X1, Y1, Y2) else if Y1 = Y2 then HorzLineTSP(X1, Y1, X2) else begin HorzLineTSP(X1, Y1, X2 - 1); VertLineTSP(X2, Y1, Y2 - 1); HorzLineTSP(X2, Y2, X1 + 1); VertLineTSP(X1, Y2, Y1 + 1); end; end; end; procedure TCustomBitmap32.FrameRectS(const ARect: TRect; Value: TColor32); begin with ARect do FrameRectS(Left, Top, Right, Bottom, Value); end; procedure TCustomBitmap32.FrameRectTS(const ARect: TRect; Value: TColor32); begin with ARect do FrameRectTS(Left, Top, Right, Bottom, Value); end; procedure TCustomBitmap32.RaiseRectTS(X1, Y1, X2, Y2: Integer; Contrast: Integer); var C1, C2: TColor32; begin // measuring is handled in inner drawing operations... if (X2 > X1) and (Y2 > Y1) and (X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and (X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then begin if (Contrast > 0) then begin C1 := SetAlpha(clWhite32, Clamp(Contrast * 512 div 100)); C2 := SetAlpha(clBlack32, Clamp(Contrast * $FF div 100)); end else if Contrast < 0 then begin Contrast := -Contrast; C1 := SetAlpha(clBlack32, Clamp(Contrast * $FF div 100)); C2 := SetAlpha(clWhite32, Clamp(Contrast * 512 div 100)); end else Exit; Dec(X2); Dec(Y2); HorzLineTS(X1, Y1, X2, C1); HorzLineTS(X1, Y2, X2, C2); Inc(Y1); Dec(Y2); VertLineTS(X1, Y1, Y2, C1); VertLineTS(X2, Y1, Y2, C2); end; end; procedure TCustomBitmap32.RaiseRectTS(const ARect: TRect; Contrast: Integer); begin with ARect do RaiseRectTS(Left, Top, Right, Bottom, Contrast); end; procedure TCustomBitmap32.LoadFromStream(Stream: TStream); var I, W: integer; Header: TBmpHeader; B: TBitmap; begin Stream.ReadBuffer(Header, SizeOf(TBmpHeader)); // Check for Windows bitmap magic bytes and general compatibility of the // bitmap data that ought to be loaded... if (Header.bfType = $4D42) and (Header.biBitCount = 32) and (Header.biPlanes = 1) and (Header.biCompression = 0) then begin SetSize(Header.biWidth, Abs(Header.biHeight)); // Check whether the bitmap is saved top-down if Header.biHeight > 0 then begin W := Width shl 2; for I := Height - 1 downto 0 do Stream.ReadBuffer(Scanline[I]^, W); end else Stream.ReadBuffer(Bits^, Width * Height shl 2); end else begin Stream.Seek(-SizeOf(TBmpHeader), soFromCurrent); B := TBitmap.Create; try B.LoadFromStream(Stream); Assign(B); finally B.Free; end; end; Changed; end; procedure TCustomBitmap32.SaveToStream(Stream: TStream; SaveTopDown: Boolean = False); var Header: TBmpHeader; BitmapSize: Integer; I, W: Integer; begin BitmapSize := Width * Height shl 2; Header.bfType := $4D42; // Magic bytes for Windows Bitmap Header.bfSize := BitmapSize + SizeOf(TBmpHeader); Header.bfReserved := 0; // Save offset relative. However, the spec says it has to be file absolute, // which we can not do properly within a stream... Header.bfOffBits := SizeOf(TBmpHeader); Header.biSize := $28; Header.biWidth := Width; if SaveTopDown then Header.biHeight := Height else Header.biHeight := -Height; Header.biPlanes := 1; Header.biBitCount := 32; Header.biCompression := 0; // bi_rgb Header.biSizeImage := BitmapSize; Header.biXPelsPerMeter := 0; Header.biYPelsPerMeter := 0; Header.biClrUsed := 0; Header.biClrImportant := 0; Stream.WriteBuffer(Header, SizeOf(TBmpHeader)); if SaveTopDown then begin W := Width shl 2; for I := Height - 1 downto 0 do Stream.WriteBuffer(PixelPtr[0, I]^, W); end else begin // NOTE: We can save the whole buffer in one run because // we do not support scanline strides (yet). Stream.WriteBuffer(Bits^, BitmapSize); end; end; procedure TCustomBitmap32.LoadFromFile(const FileName: string); var FileStream: TFileStream; Header: TBmpHeader; P: TPicture; begin FileStream := TFileStream.Create(Filename, fmOpenRead); try FileStream.ReadBuffer(Header, SizeOf(TBmpHeader)); // Check for Windows bitmap magic bytes... if Header.bfType = $4D42 then begin // if it is, use our stream read method... FileStream.Seek(-SizeOf(TBmpHeader), soFromCurrent); LoadFromStream(FileStream); Exit; end finally FileStream.Free; end; // if we got here, use the fallback approach via TPicture... P := TPicture.Create; try P.LoadFromFile(FileName); Assign(P); finally P.Free; end; end; procedure TCustomBitmap32.SaveToFile(const FileName: string; SaveTopDown: Boolean = False); var FileStream: TFileStream; begin FileStream := TFileStream.Create(Filename, fmCreate); try SaveToStream(FileStream, SaveTopDown); finally FileStream.Free; end; end; procedure TCustomBitmap32.LoadFromResourceID(Instance: THandle; ResID: Integer); var B: TBitmap; begin B := TBitmap.Create; try B.LoadFromResourceID(Instance, ResID); Assign(B); finally B.Free; Changed; end; end; procedure TCustomBitmap32.LoadFromResourceName(Instance: THandle; const ResName: string); var B: TBitmap; begin B := TBitmap.Create; try B.LoadFromResourceName(Instance, ResName); Assign(B); finally B.Free; Changed; end; end; function TCustomBitmap32.Equal(B: TCustomBitmap32): Boolean; var S1, S2: TMemoryStream; begin Result := (B <> nil) and (ClassType = B.ClassType); if Empty or B.Empty then begin Result := Empty and B.Empty; Exit; end; if Result then begin S1 := TMemoryStream.Create; try SaveToStream(S1); S2 := TMemoryStream.Create; try B.SaveToStream(S2); Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size); finally S2.Free; end; finally S1.Free; end; end; end; procedure TCustomBitmap32.DefineProperties(Filer: TFiler); function DoWrite: Boolean; begin if Filer.Ancestor <> nil then Result := not (Filer.Ancestor is TCustomBitmap32) or not Equal(TCustomBitmap32(Filer.Ancestor)) else Result := not Empty; end; begin Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite); end; procedure TCustomBitmap32.ReadData(Stream: TStream); var Width, Height: Integer; begin try Stream.ReadBuffer(Width, 4); Stream.ReadBuffer(Height, 4); SetSize(Width, Height); Stream.ReadBuffer(Bits[0], FWidth * FHeight * 4); finally Changed; end; end; procedure TCustomBitmap32.WriteData(Stream: TStream); begin Stream.WriteBuffer(FWidth, 4); Stream.WriteBuffer(FHeight, 4); Stream.WriteBuffer(Bits[0], FWidth * FHeight * 4); end; procedure TCustomBitmap32.SetCombineMode(const Value: TCombineMode); begin if FCombineMode <> Value then begin FCombineMode := Value; BlendProc := @BLEND_MEM[FCombineMode]^; Changed; end; end; procedure TCustomBitmap32.SetDrawMode(Value: TDrawMode); begin if FDrawMode <> Value then begin FDrawMode := Value; Changed; end; end; procedure TCustomBitmap32.SetWrapMode(Value: TWrapMode); begin if FWrapMode <> Value then begin FWrapMode := Value; WrapProcHorz := GetWrapProcEx(WrapMode, FClipRect.Left, FClipRect.Right - 1); WrapProcVert := GetWrapProcEx(WrapMode, FClipRect.Top, FClipRect.Bottom - 1); Changed; end; end; procedure TCustomBitmap32.SetMasterAlpha(Value: Cardinal); begin if FMasterAlpha <> Value then begin FMasterAlpha := Value; Changed; end; end; {$IFDEF DEPRECATEDMODE} procedure TCustomBitmap32.SetStretchFilter(Value: TStretchFilter); begin if FStretchFilter <> Value then begin FStretchFilter := Value; case FStretchFilter of sfNearest: TNearestResampler.Create(Self); sfDraft: TDraftResampler.Create(Self); sfLinear: TLinearResampler.Create(Self); else TKernelResampler.Create(Self); with FResampler as TKernelResampler do case FStretchFilter of sfCosine: Kernel := TCosineKernel.Create; sfSpline: Kernel := TSplineKernel.Create; sfLanczos: Kernel := TLanczosKernel.Create; sfMitchell: Kernel := TMitchellKernel.Create; end; end; Changed; end; end; {$ENDIF} procedure TCustomBitmap32.Roll(Dx, Dy: Integer; FillBack: Boolean; FillColor: TColor32); var Shift, L: Integer; R: TRect; begin if Empty or ((Dx = 0) and (Dy = 0)) then Exit; if (Abs(Dx) >= Width) or (Abs(Dy) >= Height) then begin if FillBack then Clear(FillColor); Exit; end; Shift := Dx + Dy * Width; L := (Width * Height - Abs(Shift)); if Shift > 0 then Move(Bits[0], Bits[Shift], L shl 2) else MoveLongword(Bits[-Shift], Bits[0], L); if FillBack then begin R := MakeRect(0, 0, Width, Height); OffsetRect(R, Dx, Dy); IntersectRect(R, R, MakeRect(0, 0, Width, Height)); if R.Top > 0 then FillRect(0, 0, Width, R.Top, FillColor) else if R.Top = 0 then FillRect(0, R.Bottom, Width, Height, FillColor); if R.Left > 0 then FillRect(0, R.Top, R.Left, R.Bottom, FillColor) else if R.Left = 0 then FillRect(R.Right, R.Top, Width, R.Bottom, FillColor); end; Changed; end; procedure TCustomBitmap32.FlipHorz(Dst: TCustomBitmap32); var i, j: Integer; P1, P2: PColor32; tmp: TColor32; W, W2: Integer; begin W := Width; if (Dst = nil) or (Dst = Self) then begin { In-place flipping } P1 := PColor32(Bits); P2 := P1; Inc(P2, Width - 1); W2 := Width shr 1; for J := 0 to Height - 1 do begin for I := 0 to W2 - 1 do begin tmp := P1^; P1^ := P2^; P2^ := tmp; Inc(P1); Dec(P2); end; Inc(P1, W - W2); Inc(P2, W + W2); end; Changed; end else begin { Flip to Dst } Dst.BeginUpdate; Dst.SetSize(W, Height); P1 := PColor32(Bits); P2 := PColor32(Dst.Bits); Inc(P2, W - 1); for J := 0 to Height - 1 do begin for I := 0 to W - 1 do begin P2^ := P1^; Inc(P1); Dec(P2); end; Inc(P2, W shl 1); end; Dst.EndUpdate; Dst.Changed; end; end; procedure TCustomBitmap32.FlipVert(Dst: TCustomBitmap32); var J, J2: Integer; Buffer: PColor32Array; P1, P2: PColor32; begin if (Dst = nil) or (Dst = Self) then begin { in-place } J2 := Height - 1; GetMem(Buffer, Width shl 2); for J := 0 to Height div 2 - 1 do begin P1 := PixelPtr[0, J]; P2 := PixelPtr[0, J2]; MoveLongword(P1^, Buffer^, Width); MoveLongword(P2^, P1^, Width); MoveLongword(Buffer^, P2^, Width); Dec(J2); end; FreeMem(Buffer); Changed; end else begin Dst.SetSize(Width, Height); J2 := Height - 1; for J := 0 to Height - 1 do begin MoveLongword(PixelPtr[0, J]^, Dst.PixelPtr[0, J2]^, Width); Dec(J2); end; Dst.Changed; end; end; procedure TCustomBitmap32.Rotate90(Dst: TCustomBitmap32); var Tmp: TCustomBitmap32; X, Y, I, J: Integer; begin if Dst = nil then begin Tmp := TCustomBitmap32.Create; Dst := Tmp; end else begin Tmp := nil; Dst.BeginUpdate; end; Dst.SetSize(Height, Width); I := 0; for Y := 0 to Height - 1 do begin J := Height - 1 - Y; for X := 0 to Width - 1 do begin Dst.Bits[J] := Bits[I]; Inc(I); Inc(J, Height); end; end; if Tmp <> nil then begin Tmp.CopyMapTo(Self); Tmp.Free; end else begin Dst.EndUpdate; Dst.Changed; end; end; procedure TCustomBitmap32.Rotate180(Dst: TCustomBitmap32); var I, I2: Integer; Tmp: TColor32; begin if Dst <> nil then begin Dst.SetSize(Width, Height); I2 := Width * Height - 1; for I := 0 to Width * Height - 1 do begin Dst.Bits[I2] := Bits[I]; Dec(I2); end; Dst.Changed; end else begin I2 := Width * Height - 1; for I := 0 to Width * Height div 2 - 1 do begin Tmp := Bits[I2]; Bits[I2] := Bits[I]; Bits[I] := Tmp; Dec(I2); end; Changed; end; end; procedure TCustomBitmap32.Rotate270(Dst: TCustomBitmap32); var Tmp: TCustomBitmap32; X, Y, I, J: Integer; begin if Dst = nil then begin Tmp := TCustomBitmap32.Create; { TODO : Revise creating of temporary bitmaps here... } Dst := Tmp; end else begin Tmp := nil; Dst.BeginUpdate; end; Dst.SetSize(Height, Width); I := 0; for Y := 0 to Height - 1 do begin J := (Width - 1) * Height + Y; for X := 0 to Width - 1 do begin Dst.Bits[J] := Bits[I]; Inc(I); Dec(J, Height); end; end; if Tmp <> nil then begin Tmp.CopyMapTo(Self); Tmp.Free; end else begin Dst.EndUpdate; Dst.Changed; end; end; function TCustomBitmap32.BoundsRect: TRect; begin Result.Left := 0; Result.Top := 0; Result.Right := Width; Result.Bottom := Height; end; procedure TCustomBitmap32.SetClipRect(const Value: TRect); begin IntersectRect(FClipRect, Value, BoundsRect); FFixedClipRect := FixedRect(FClipRect); with FClipRect do F256ClipRect := Rect(Left shl 8, Top shl 8, Right shl 8, Bottom shl 8); FClipping := not EqualRect(FClipRect, BoundsRect); WrapProcHorz := GetWrapProcEx(WrapMode, FClipRect.Left, FClipRect.Right - 1); WrapProcVert := GetWrapProcEx(WrapMode, FClipRect.Top, FClipRect.Bottom - 1); end; procedure TCustomBitmap32.ResetClipRect; begin ClipRect := BoundsRect; end; procedure TCustomBitmap32.BeginMeasuring(const Callback: TAreaChangedEvent); begin FMeasuringMode := True; FOldOnAreaChanged := FOnAreaChanged; FOnAreaChanged := Callback; end; procedure TCustomBitmap32.EndMeasuring; begin FMeasuringMode := False; FOnAreaChanged := FOldOnAreaChanged; end; procedure TCustomBitmap32.PropertyChanged; begin // don't force invalidation of whole bitmap area as this is unnecessary inherited Changed; end; procedure TCustomBitmap32.Changed; begin if ((FUpdateCount = 0) or FMeasuringMode) and Assigned(FOnAreaChanged) then FOnAreaChanged(Self, BoundsRect, AREAINFO_RECT); if not FMeasuringMode then inherited; end; procedure TCustomBitmap32.Changed(const Area: TRect; const Info: Cardinal); begin if ((FUpdateCount = 0) or FMeasuringMode) and Assigned(FOnAreaChanged) then FOnAreaChanged(Self, Area, Info); if not FMeasuringMode then inherited Changed; end; procedure TCustomBitmap32.SetResampler(Resampler: TCustomResampler); begin if Assigned(Resampler) and (FResampler <> Resampler) then begin if Assigned(FResampler) then FResampler.Free; FResampler := Resampler; Changed; end; end; function TCustomBitmap32.GetResamplerClassName: string; begin Result := FResampler.ClassName; end; procedure TCustomBitmap32.SetResamplerClassName(const Value: string); var ResamplerClass: TCustomResamplerClass; begin if (Value <> '') and (FResampler.ClassName <> Value) and Assigned(ResamplerList) then begin ResamplerClass := TCustomResamplerClass(ResamplerList.Find(Value)); if Assigned(ResamplerClass) then ResamplerClass.Create(Self); end; end; { TBitmap32 } procedure TBitmap32.FinalizeBackend; begin if Supports(Backend, IFontSupport) then (Backend as IFontSupport).OnFontChange := nil; if Supports(Backend, ICanvasSupport) then (Backend as ICanvasSupport).OnCanvasChange := nil; inherited; end; procedure TBitmap32.BackendChangingHandler(Sender: TObject); begin inherited; FontChanged(Self); DeleteCanvas; end; procedure TBitmap32.BackendChangedHandler(Sender: TObject); begin inherited; HandleChanged; end; procedure TBitmap32.FontChanged(Sender: TObject); begin // TODO: still required? end; procedure TBitmap32.CanvasChanged(Sender: TObject); begin Changed; end; procedure TBitmap32.CopyPropertiesTo(Dst: TCustomBitmap32); begin inherited; if (Dst is TBitmap32) and Supports(Dst.Backend, IFontSupport) and Supports(Self.Backend, IFontSupport) then TBitmap32(Dst).Font.Assign(Self.Font); end; function TBitmap32.GetCanvas: TCanvas; begin Result := (FBackend as ICanvasSupport).Canvas; end; function TBitmap32.GetBitmapInfo: TBitmapInfo; begin Result := (FBackend as IBitmapContextSupport).BitmapInfo; end; function TBitmap32.GetHandle: HBITMAP; begin Result := (FBackend as IBitmapContextSupport).BitmapHandle; end; function TBitmap32.GetHDC: HDC; begin Result := (FBackend as IDeviceContextSupport).Handle; end; class function TBitmap32.GetPlatformBackendClass: TCustomBackendClass; begin {$IFDEF FPC} Result := TLCLBackend; {$ELSE} Result := TGDIBackend; {$ENDIF} end; function TBitmap32.GetFont: TFont; begin Result := (FBackend as IFontSupport).Font; end; procedure TBitmap32.SetBackend(const Backend: TCustomBackend); var FontSupport: IFontSupport; CanvasSupport: ICanvasSupport; begin if Assigned(Backend) and (Backend <> FBackend) then begin if Supports(Backend, IFontSupport, FontSupport) then FontSupport.OnFontChange := FontChanged; if Supports(Backend, ICanvasSupport, CanvasSupport) then CanvasSupport.OnCanvasChange := CanvasChanged; inherited; end; end; procedure TBitmap32.SetFont(Value: TFont); begin (FBackend as IFontSupport).Font := Value; end; procedure TBitmap32.HandleChanged; begin if Assigned(FOnHandleChanged) then FOnHandleChanged(Self); end; {$IFDEF BCB} procedure TBitmap32.Draw(const DstRect, SrcRect: TRect; hSrc: Cardinal); {$ELSE} procedure TBitmap32.Draw(const DstRect, SrcRect: TRect; hSrc: HDC); {$ENDIF} begin (FBackend as IDeviceContextSupport).Draw(DstRect, SrcRect, hSrc); end; procedure TBitmap32.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer); begin if Empty then Exit; (FBackend as IDeviceContextSupport).DrawTo(hDst, DstX, DstY); end; procedure TBitmap32.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect); begin if Empty then Exit; (FBackend as IDeviceContextSupport).DrawTo(hDst, DstRect, SrcRect); end; procedure TBitmap32.TileTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect); const MaxTileSize = 1024; var DstW, DstH: Integer; TilesX, TilesY: Integer; Buffer: TCustomBitmap32; I, J: Integer; ClipRect, R: TRect; X, Y: Integer; begin DstW := DstRect.Right - DstRect.Left; DstH := DstRect.Bottom - DstRect.Top; TilesX := (DstW + MaxTileSize - 1) div MaxTileSize; TilesY := (DstH + MaxTileSize - 1) div MaxTileSize; Buffer := TBitmap32.Create; try for J := 0 to TilesY - 1 do begin for I := 0 to TilesX - 1 do begin ClipRect.Left := I * MaxTileSize; ClipRect.Top := J * MaxTileSize; ClipRect.Right := (I + 1) * MaxTileSize; ClipRect.Bottom := (J + 1) * MaxTileSize; if ClipRect.Right > DstW then ClipRect.Right := DstW; if ClipRect.Bottom > DstH then ClipRect.Bottom := DstH; X := ClipRect.Left; Y := ClipRect.Top; OffsetRect(ClipRect, -X, -Y); R := DstRect; OffsetRect(R, -X - DstRect.Left, -Y - DstRect.Top); Buffer.SetSize(ClipRect.Right, ClipRect.Bottom); StretchTransfer(Buffer, R, ClipRect, Self, SrcRect, Resampler, DrawMode, FOnPixelCombine); (Buffer.Backend as IDeviceContextSupport).DrawTo(hDst, MakeRect(X + DstRect.Left, Y + DstRect.Top, X + ClipRect.Right, Y + ClipRect.Bottom), MakeRect(0, 0, Buffer.Width, Buffer.Height) ); end; end; finally Buffer.Free; end; end; procedure TBitmap32.UpdateFont; begin (FBackend as IFontSupport).UpdateFont; end; // Text and Fonts // function TBitmap32.TextExtent(const Text: string): TSize; begin Result := (FBackend as ITextSupport).TextExtent(Text); end; function TBitmap32.TextExtentW(const Text: Widestring): TSize; begin Result := (FBackend as ITextSupport).TextExtentW(Text); end; // ------------------------------------------------------------------- procedure TBitmap32.Textout(X, Y: Integer; const Text: string); begin (FBackend as ITextSupport).Textout(X, Y, Text); end; procedure TBitmap32.TextoutW(X, Y: Integer; const Text: Widestring); begin (FBackend as ITextSupport).TextoutW(X, Y, Text); end; // ------------------------------------------------------------------- procedure TBitmap32.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); begin (FBackend as ITextSupport).Textout(X, Y, ClipRect, Text); end; procedure TBitmap32.TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); begin (FBackend as ITextSupport).TextoutW(X, Y, ClipRect, Text); end; // ------------------------------------------------------------------- procedure TBitmap32.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); begin (FBackend as ITextSupport).Textout(DstRect, Flags, Text); end; procedure TBitmap32.TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); begin (FBackend as ITextSupport).TextoutW(DstRect, Flags, Text); end; // ------------------------------------------------------------------- function TBitmap32.TextHeight(const Text: string): Integer; begin Result := (FBackend as ITextSupport).TextExtent(Text).cY; end; function TBitmap32.TextHeightW(const Text: Widestring): Integer; begin Result := (FBackend as ITextSupport).TextExtentW(Text).cY; end; // ------------------------------------------------------------------- function TBitmap32.TextWidth(const Text: string): Integer; begin Result := (FBackend as ITextSupport).TextExtent(Text).cX; end; function TBitmap32.TextWidthW(const Text: Widestring): Integer; begin Result := (FBackend as ITextSupport).TextExtentW(Text).cX; end; // ------------------------------------------------------------------- {$IFNDEF FPC} procedure SetFontAntialiasing(const Font: TFont; Quality: Cardinal); var LogFont: TLogFont; begin with LogFont do begin lfHeight := Font.Height; lfWidth := 0; { have font mapper choose } {$IFDEF COMPILER2005_UP} lfEscapement := Font.Orientation; lfOrientation := Font.Orientation; {$ELSE} lfEscapement := 0; lfOrientation := 0; {$ENDIF} if fsBold in Font.Style then lfWeight := FW_BOLD else lfWeight := FW_NORMAL; lfItalic := Byte(fsItalic in Font.Style); lfUnderline := Byte(fsUnderline in Font.Style); lfStrikeOut := Byte(fsStrikeOut in Font.Style); lfCharSet := Byte(Font.Charset); // TODO DVT Added cast to fix TFontDataName to string warning. Need to verify is OK if AnsiCompareText(Font.Name, 'Default') = 0 then // do not localize StrPCopy(lfFaceName, string(DefFontData.Name)) else StrPCopy(lfFaceName, Font.Name); lfQuality := Quality; { Only True Type fonts support the angles } if lfOrientation <> 0 then lfOutPrecision := OUT_TT_ONLY_PRECIS else lfOutPrecision := OUT_DEFAULT_PRECIS; lfClipPrecision := CLIP_DEFAULT_PRECIS; case Font.Pitch of fpVariable: lfPitchAndFamily := VARIABLE_PITCH; fpFixed: lfPitchAndFamily := FIXED_PITCH; else lfPitchAndFamily := DEFAULT_PITCH; end; end; Font.Handle := CreateFontIndirect(LogFont); end; {$ENDIF} procedure TextBlueToAlpha(const B: TCustomBitmap32; const Color: TColor32); (* asm PUSH EDI MOV ECX, [B+$44].Integer IMUL ECX, [B+$40].Integer MOV EDI, [B+$54].Integer @PixelLoop: MOV EAX, [EDI] SHL EAX, 24 ADD EAX, Color MOV [EDI], EAX ADD EDI, 4 LOOP @PixelLoop POP EDI end; *) var I: Integer; P: PColor32; C: TColor32; begin // convert blue channel to alpha and fill the color P := @B.Bits[0]; for I := 0 to B.Width * B.Height - 1 do begin C := P^; if C <> 0 then begin C := P^ shl 24; // transfer blue channel to alpha C := C + Color; P^ := C; end; Inc(P); end; end; procedure TextScaleDown(const B, B2: TCustomBitmap32; const N: Integer; const Color: TColor32); // use only the blue channel var I, J, X, Y, P, Q, Sz, S: Integer; Src: PColor32; Dst: PColor32; begin Sz := 1 shl N - 1; Dst := B.PixelPtr[0, 0]; for J := 0 to B.Height - 1 do begin Y := J shl N; for I := 0 to B.Width - 1 do begin X := I shl N; S := 0; for Q := Y to Y + Sz do begin Src := B2.PixelPtr[X, Q]; for P := X to X + Sz do begin S := S + Integer(Src^ and $000000FF); Inc(Src); end; end; S := S shr N shr N; Dst^ := TColor32(S shl 24) + Color; Inc(Dst); end; end; end; procedure TBitmap32.RenderText(X, Y: Integer; const Text: string; AALevel: Integer; Color: TColor32); var B, B2: TBitmap32; Sz: TSize; Alpha: TColor32; PaddedText: string; begin if Empty then Exit; Alpha := Color shr 24; Color := Color and $00FFFFFF; AALevel := Constrain(AALevel, -1, 4); PaddedText := Text + ' '; {$IFDEF FPC} if AALevel > -1 then Font.Quality := fqNonAntialiased else Font.Quality := fqAntialiased; {$ELSE} if AALevel > -1 then SetFontAntialiasing(Font, NONANTIALIASED_QUALITY) else SetFontAntialiasing(Font, ANTIALIASED_QUALITY); {$ENDIF} { TODO : Optimize Clipping here } B := TBitmap32.Create; with B do try if AALevel <= 0 then begin Sz := Self.TextExtent(PaddedText); if Sz.cX > Self.Width then Sz.cX := Self.Width; if Sz.cY > Self.Height then Sz.cX := Self.Height; SetSize(Sz.cX, Sz.cY); Font := Self.Font; Clear(0); Font.Color := clWhite; Textout(0, 0, Text); TextBlueToAlpha(B, Color); end else begin B2 := TBitmap32.Create; with B2 do try Font := Self.Font; Font.Size := Self.Font.Size shl AALevel; Font.Color := clWhite; Sz := TextExtent(PaddedText); Sz.Cx := Sz.cx + 1 shl AALevel; Sz.Cy := Sz.cy + 1 shl AALevel; SetSize(Sz.Cx, Sz.Cy); Clear(0); Textout(0, 0, Text); B.SetSize(Sz.cx shr AALevel, Sz.cy shr AALevel); TextScaleDown(B, B2, AALevel, Color); finally Free; end; end; DrawMode := dmBlend; MasterAlpha := Alpha; CombineMode := CombineMode; DrawTo(Self, X, Y); finally Free; end; {$IFDEF FPC} Font.Quality := fqDefault; {$ELSE} SetFontAntialiasing(Font, DEFAULT_QUALITY); {$ENDIF} end; procedure TBitmap32.RenderTextW(X, Y: Integer; const Text: Widestring; AALevel: Integer; Color: TColor32); var B, B2: TBitmap32; Sz: TSize; Alpha: TColor32; StockCanvas: TCanvas; PaddedText: Widestring; begin if Empty then Exit; Alpha := Color shr 24; Color := Color and $00FFFFFF; AALevel := Constrain(AALevel, -1, 4); PaddedText := Text + ' '; {$IFDEF FPC} if AALevel > -1 then Font.Quality := fqNonAntialiased else Font.Quality := fqAntialiased; {$ELSE} if AALevel > -1 then SetFontAntialiasing(Font, NONANTIALIASED_QUALITY) else SetFontAntialiasing(Font, ANTIALIASED_QUALITY); {$ENDIF} { TODO : Optimize Clipping here } B := TBitmap32.Create; try if AALevel <= 0 then begin Sz := TextExtentW(PaddedText); B.SetSize(Sz.cX, Sz.cY); B.Font := Font; B.Clear(0); B.Font.Color := clWhite; B.TextoutW(0, 0, Text); TextBlueToAlpha(B, Color); end else begin StockCanvas := StockBitmap.Canvas; StockCanvas.Lock; try StockCanvas.Font := Font; StockCanvas.Font.Size := Font.Size shl AALevel; {$IFDEF PLATFORM_INDEPENDENT} Sz := StockCanvas.TextExtent(PaddedText); {$ELSE} Windows.GetTextExtentPoint32W(StockCanvas.Handle, PWideChar(PaddedText), Length(PaddedText), Sz); {$ENDIF} Sz.Cx := (Sz.cx shr AALevel + 1) shl AALevel; Sz.Cy := (Sz.cy shr AALevel + 1) shl AALevel; B2 := TBitmap32.Create; try B2.SetSize(Sz.Cx, Sz.Cy); B2.Clear(0); B2.Font := StockCanvas.Font; B2.Font.Color := clWhite; B2.TextoutW(0, 0, Text); B.SetSize(Sz.cx shr AALevel, Sz.cy shr AALevel); TextScaleDown(B, B2, AALevel, Color); finally B2.Free; end; finally StockCanvas.Unlock; end; end; B.DrawMode := dmBlend; B.MasterAlpha := Alpha; B.CombineMode := CombineMode; B.DrawTo(Self, X, Y); finally B.Free; end; {$IFDEF FPC} Font.Quality := fqDefault; {$ELSE} SetFontAntialiasing(Font, DEFAULT_QUALITY); {$ENDIF} end; // ------------------------------------------------------------------- function TBitmap32.CanvasAllocated: Boolean; begin Result := (FBackend as ICanvasSupport).CanvasAllocated; end; procedure TBitmap32.DeleteCanvas; begin if Supports(Backend, ICanvasSupport) then (FBackend as ICanvasSupport).DeleteCanvas; end; { TCustomBackend } constructor TCustomBackend.Create; begin RefCounted := True; _AddRef; inherited; end; constructor TCustomBackend.Create(Owner: TCustomBitmap32); begin FOwner := Owner; Create; if Assigned(Owner) then Owner.Backend := Self; end; destructor TCustomBackend.Destroy; begin Clear; inherited; end; procedure TCustomBackend.Clear; var Width, Height: Integer; begin if Assigned(FOwner) then ChangeSize(FOwner.FWidth, FOwner.FHeight, 0, 0, False) else ChangeSize(Width, Height, 0, 0, False); end; procedure TCustomBackend.Changing; begin if Assigned(FOnChanging) then FOnChanging(Self); end; {$IFDEF BITS_GETTER} function TCustomBackend.GetBits: PColor32Array; begin Result := FBits; end; {$ENDIF} procedure TCustomBackend.ChangeSize(out Width, Height: Integer; NewWidth, NewHeight: Integer; ClearBuffer: Boolean); begin try Changing; FinalizeSurface; Width := 0; Height := 0; if (NewWidth > 0) and (NewHeight > 0) then InitializeSurface(NewWidth, NewHeight, ClearBuffer); Width := NewWidth; Height := NewHeight; finally Changed; end; end; procedure TCustomBackend.Assign(Source: TPersistent); var SrcBackend: TCustomBackend; begin if Source is TCustomBackend then begin if Assigned(FOwner) then begin SrcBackend := TCustomBackend(Source); ChangeSize( FOwner.FWidth, FOwner.FHeight, SrcBackend.FOwner.Width, SrcBackend.FOwner.Height, False ); if not SrcBackend.Empty then MoveLongword( SrcBackend.Bits[0], Bits[0], SrcBackend.FOwner.Width * SrcBackend.FOwner.Height ); end; end else inherited; end; function TCustomBackend.Empty: Boolean; begin Result := False; end; procedure TCustomBackend.FinalizeSurface; begin // descendants override this method end; procedure TCustomBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); begin // descendants override this method end; { TCustomSampler } function TCustomSampler.GetSampleInt(X, Y: Integer): TColor32; begin Result := GetSampleFixed(X * FixedOne, Y * FixedOne); end; function TCustomSampler.GetSampleFixed(X, Y: TFixed): TColor32; begin Result := GetSampleFloat(X * FixedToFloat, Y * FixedToFloat); end; function TCustomSampler.GetSampleFloat(X, Y: TFloat): TColor32; begin Result := GetSampleFixed(Fixed(X), Fixed(Y)); end; procedure TCustomSampler.PrepareSampling; begin // descendants override this method end; procedure TCustomSampler.FinalizeSampling; begin // descendants override this method end; function TCustomSampler.HasBounds: Boolean; begin Result := False; end; function TCustomSampler.GetSampleBounds: TFloatRect; const InfRect: TFloatRect = (Left: -Infinity; Top: -Infinity; Right: Infinity; Bottom: Infinity); begin Result := InfRect; end; { TCustomResampler } procedure TCustomResampler.AssignTo(Dst: TPersistent); begin if Dst is TCustomResampler then SmartAssign(Self, Dst) else inherited; end; procedure TCustomResampler.Changed; begin if Assigned(FBitmap) then FBitmap.Changed; end; constructor TCustomResampler.Create; begin inherited; FPixelAccessMode := pamSafe; end; constructor TCustomResampler.Create(ABitmap: TCustomBitmap32); begin Create; FBitmap := ABitmap; if Assigned(ABitmap) then ABitmap.Resampler := Self; end; function TCustomResampler.GetSampleBounds: TFloatRect; begin Result := FloatRect(FBitmap.ClipRect); if PixelAccessMode = pamTransparentEdge then InflateRect(Result, 1, 1); end; function TCustomResampler.GetWidth: TFloat; begin Result := 0; end; function TCustomResampler.HasBounds: Boolean; begin Result := FPixelAccessMode <> pamWrap; end; procedure TCustomResampler.PrepareSampling; begin FClipRect := FBitmap.ClipRect; end; procedure TCustomResampler.SetPixelAccessMode( const Value: TPixelAccessMode); begin if FPixelAccessMode <> Value then begin FPixelAccessMode := Value; Changed; end; end; initialization SetGamma; StockBitmap := TBitmap.Create; StockBitmap.Width := 8; StockBitmap.Height := 8; finalization StockBitmap.Free; end. |
Added src/graphics32/GR32_ArrowHeads.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 | unit GR32_ArrowHeads; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Vectorial Polygon Rasterizer for Graphics32 * * The Initial Developer of the Original Code is * Angus Johnson < http://www.angusj.com > * * Portions created by the Initial Developer are Copyright (C) 2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface uses SysUtils, GR32, GR32_Polygons, GR32_VectorUtils, GR32_Geometry; type TArrowHeadAbstract = class private FSize: TFloat; FTipPoint: TFloatPoint; FBasePoint: TFloatPoint; protected function GetPointsInternal: TArrayOfFloatPoint; virtual; abstract; public constructor Create(size: TFloat); virtual; function GetPoints(const Line: TArrayOfFloatPoint; AtEnd: Boolean): TArrayOfFloatPoint; //Size: distance between arrow tip and arrow base property Size: TFloat read FSize write FSize; end; TArrowHeadSimple = class(TArrowHeadAbstract) protected function GetPointsInternal: TArrayOfFloatPoint; override; end; TArrowHeadFourPt = class(TArrowHeadAbstract) protected function GetPointsInternal: TArrayOfFloatPoint; override; end; TArrowHeadCircle = class(TArrowHeadAbstract) protected function GetPointsInternal: TArrayOfFloatPoint; override; end; TArrowHeadDiamond = class(TArrowHeadAbstract) protected function GetPointsInternal: TArrayOfFloatPoint; override; end; resourcestring RCStrInsufficientPointsInArray = 'Insufficient points in array'; implementation constructor TArrowHeadAbstract.Create(Size: TFloat); begin FSize := Size; end; //------------------------------------------------------------------------------ function TArrowHeadAbstract.GetPoints(const Line: TArrayOfFloatPoint; AtEnd: Boolean): TArrayOfFloatPoint; var HighI: Integer; UnitVec: TFloatPoint; begin HighI := high(Line); if HighI < 1 then raise exception.create(RCStrInsufficientPointsInArray); if AtEnd then begin FBasePoint := Line[HighI]; UnitVec := GetUnitVector(Line[HighI -1], Line[HighI]); end else begin FBasePoint := Line[0]; UnitVec := GetUnitVector(Line[1], Line[0]); end; FTipPoint := OffsetPoint(FBasePoint, UnitVec.X * FSize, UnitVec.Y * FSize); Result := GetPointsInternal; end; //------------------------------------------------------------------------------ function TArrowHeadSimple.GetPointsInternal: TArrayOfFloatPoint; var UnitNorm: TFloatPoint; Sz: Single; begin SetLength(Result, 3); UnitNorm := GetUnitNormal(FTipPoint, FBasePoint); Sz := FSize * 0.5; Result[0] := FTipPoint; Result[1] := OffsetPoint(FBasePoint, UnitNorm.X *Sz, UnitNorm.Y *Sz); Result[2] := OffsetPoint(FBasePoint, -UnitNorm.X *Sz, -UnitNorm.Y *Sz); end; //------------------------------------------------------------------------------ function TArrowHeadFourPt.GetPointsInternal: TArrayOfFloatPoint; var Angle: Double; begin SetLength(Result, 4); Result[0] := FTipPoint; Angle := GetAngleOfPt2FromPt1(FTipPoint, FBasePoint); Result[1] := GetPointAtAngleFromPoint(FBasePoint, FSize * 0.5, Angle + CRad60); Result[2] := FBasePoint; Result[3] := GetPointAtAngleFromPoint(FBasePoint, FSize * 0.5, Angle - CRad60); end; //------------------------------------------------------------------------------ function TArrowHeadCircle.GetPointsInternal: TArrayOfFloatPoint; var MidPt: TFloatPoint; begin MidPt := Average(FTipPoint, FBasePoint); Result := Circle(MidPt.X, MidPt.Y, FSize * 0.5, Round(FSize)); end; //------------------------------------------------------------------------------ function TArrowHeadDiamond.GetPointsInternal: TArrayOfFloatPoint; var MidPt, UnitNorm: TFloatPoint; Sz: Single; begin MidPt := Average(FTipPoint, FBasePoint); UnitNorm := GetUnitNormal(FTipPoint, FBasePoint); Sz := FSize / 3; SetLength(Result, 4); Result[0] := FTipPoint; Result[1] := OffsetPoint(MidPt, UnitNorm.X * Sz, UnitNorm.Y * Sz); Result[2] := FBasePoint; Result[3] := OffsetPoint(MidPt, -UnitNorm.X * Sz, -UnitNorm.Y * Sz); end; //------------------------------------------------------------------------------ end. |
Added src/graphics32/GR32_Backends.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 | unit GR32_Backends; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Backend Extension for Graphics32 * * The Initial Developer of the Original Code is * Andre Beckedorf - metaException * Andre@metaException.de * * Portions created by the Initial Developer are Copyright (C) 2007-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LCLType, Types, Controls, Graphics, {$ELSE} Windows, Messages, Controls, Graphics, {$ENDIF} Classes, SysUtils, GR32, GR32_Containers, GR32_Image, GR32_Paths; type EBackend = class(Exception); ITextSupport = interface(IUnknown) ['{225997CC-958A-423E-8B60-9EDE0D3B53B5}'] procedure Textout(X, Y: Integer; const Text: String); overload; procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: String); overload; procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: String); overload; function TextExtent(const Text: String): TSize; procedure TextoutW(X, Y: Integer; const Text: Widestring); overload; procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload; procedure TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload; function TextExtentW(const Text: Widestring): TSize; end; IFontSupport = interface(IUnknown) ['{67C73044-1EFF-4FDE-AEA2-56BFADA50A48}'] function GetOnFontChange: TNotifyEvent; procedure SetOnFontChange(Handler: TNotifyEvent); function GetFont: TFont; procedure SetFont(const Font: TFont); procedure UpdateFont; property Font: TFont read GetFont write SetFont; property OnFontChange: TNotifyEvent read GetOnFontChange write SetOnFontChange; end; ITextToPathSupport = interface(IUnknown) ['{6C4037E4-FF4D-4EE2-9C20-B9DB9C64B42D}'] procedure TextToPath(Path: TCustomPath; const X, Y: TFloat; const Text: WideString); overload; procedure TextToPath(Path: TCustomPath; const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal); overload; function MeasureText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; end; ICanvasSupport = interface(IUnknown) ['{5ACFEEC7-0123-4AD8-8AE6-145718438E01}'] function GetCanvasChange: TNotifyEvent; procedure SetCanvasChange(Handler: TNotifyEvent); function GetCanvas: TCanvas; procedure DeleteCanvas; function CanvasAllocated: Boolean; property Canvas: TCanvas read GetCanvas; property OnCanvasChange: TNotifyEvent read GetCanvasChange write SetCanvasChange; end; IDeviceContextSupport = interface(IUnknown) ['{DD1109DA-4019-4A5C-A450-3631A73CF288}'] function GetHandle: HDC; procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload; procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; property Handle: HDC read GetHandle; end; IBitmapContextSupport = interface(IUnknown) ['{DF0F9475-BA13-4C6B-81C3-D138624C4D08}'] function GetBitmapInfo: TBitmapInfo; function GetBitmapHandle: THandle; property BitmapInfo: TBitmapInfo read GetBitmapInfo; property BitmapHandle: THandle read GetBitmapHandle; end; IPaintSupport = interface(IUnknown) ['{CE64DBEE-C4A9-4E8E-ABCA-1B1FD6F45924}'] procedure ImageNeeded; procedure CheckPixmap; procedure DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); end; TRequireOperatorMode = (romAnd, romOr); // Helper functions to temporarily switch the back-end depending on the required interfaces procedure RequireBackendSupport(TargetBitmap: TCustomBitmap32; RequiredInterfaces: array of TGUID; Mode: TRequireOperatorMode; UseOptimizedDestructiveSwitchMethod: Boolean; out ReleasedBackend: TCustomBackend); procedure RestoreBackend(TargetBitmap: TCustomBitmap32; const SavedBackend: TCustomBackend); resourcestring RCStrCannotAllocateDIBHandle = 'Can''t allocate the DIB handle'; RCStrCannotCreateCompatibleDC = 'Can''t create compatible DC'; RCStrCannotSelectAnObjectIntoDC = 'Can''t select an object into DC'; implementation procedure RequireBackendSupport(TargetBitmap: TCustomBitmap32; RequiredInterfaces: array of TGUID; Mode: TRequireOperatorMode; UseOptimizedDestructiveSwitchMethod: Boolean; out ReleasedBackend: TCustomBackend); var I: Integer; Supported: Boolean; begin Supported := False; for I := Low(RequiredInterfaces) to High(RequiredInterfaces) do begin Supported := Supports(TargetBitmap.Backend, RequiredInterfaces[I]); if ((Mode = romAnd) and not Supported) or ((Mode = romOr) and Supported) then Break; end; if not Supported then begin if UseOptimizedDestructiveSwitchMethod then TargetBitmap.SetSize(0, 0); // Reset size so we avoid the buffer copy during back-end switch ReleasedBackend := TargetBitmap.ReleaseBackend; // TODO: Try to find a back-end that supports the required interfaces // instead of resorting to the default platform back-end class... TargetBitmap.Backend := TargetBitmap.GetPlatformBackendClass.Create; end else ReleasedBackend := nil; end; procedure RestoreBackend(TargetBitmap: TCustomBitmap32; const SavedBackend: TCustomBackend); begin if Assigned(SavedBackend) then TargetBitmap.Backend := SavedBackend; end; end. |
Added src/graphics32/GR32_Backends_Generic.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 | unit GR32_Backends_Generic; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Backend Extension for Graphics32 * * The Initial Developer of the Original Code is * Andre Beckedorf - metaException * Andre@metaException.de * * Portions created by the Initial Developer are Copyright (C) 2007-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} {$IFDEF Windows} Windows, {$ENDIF} {$ELSE} Windows, {$ENDIF} {$IFDEF USE_GUIDS_IN_MMF} ActiveX, {$ENDIF} SysUtils, Classes, GR32; type { TMemoryBackend } { A backend that keeps the backing buffer entirely in memory.} TMemoryBackend = class(TCustomBackend) protected procedure InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); override; procedure FinalizeSurface; override; end; {$IFDEF Windows} { TMMFBackend } { A backend that uses memory mapped files or mapped swap space for the backing buffer.} TMMFBackend = class(TMemoryBackend) private FMapHandle: THandle; FMapIsTemporary: boolean; FMapFileHandle: THandle; FMapFileName: string; protected procedure InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); override; procedure FinalizeSurface; override; public constructor Create(Owner: TCustomBitmap32; IsTemporary: Boolean = True; const MapFileName: string = ''); virtual; destructor Destroy; override; class procedure InitializeFileMapping(var MapHandle, MapFileHandle: THandle; var MapFileName: string); class procedure DeinitializeFileMapping(MapHandle, MapFileHandle: THandle; const MapFileName: string); class procedure CreateFileMapping(var MapHandle, MapFileHandle: THandle; var MapFileName: string; IsTemporary: Boolean; NewWidth, NewHeight: Integer); end; {$ENDIF} implementation uses GR32_LowLevel; {$IFDEF Windows} var TempPath: TFileName; resourcestring RCStrFailedToMapFile = 'Failed to map file'; RCStrFailedToCreateMapFile = 'Failed to create map file (%s)'; RCStrFailedToMapViewOfFile = 'Failed to map view of file.'; function GetTempPath: TFileName; var PC: PChar; begin PC := StrAlloc(MAX_PATH + 1); try Windows.GetTempPath(MAX_PATH, PC); Result := TFileName(PC); finally StrDispose(PC); end; end; {$ENDIF} { TMemoryBackend } procedure TMemoryBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); begin GetMem(FBits, NewWidth * NewHeight * 4); if ClearBuffer then FillLongword(FBits[0], NewWidth * NewHeight, clBlack32); end; procedure TMemoryBackend.FinalizeSurface; begin if Assigned(FBits) then begin FreeMem(FBits); FBits := nil; end; end; {$IFDEF Windows} { TMMFBackend } constructor TMMFBackend.Create(Owner: TCustomBitmap32; IsTemporary: Boolean = True; const MapFileName: string = ''); begin FMapFileName := MapFileName; FMapIsTemporary := IsTemporary; InitializeFileMapping(FMapHandle, FMapFileHandle, FMapFileName); inherited Create(Owner); end; destructor TMMFBackend.Destroy; begin DeinitializeFileMapping(FMapHandle, FMapFileHandle, FMapFileName); inherited; end; procedure TMMFBackend.FinalizeSurface; begin if Assigned(FBits) then begin UnmapViewOfFile(FBits); FBits := nil; end; end; procedure TMMFBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); begin CreateFileMapping(FMapHandle, FMapFileHandle, FMapFileName, FMapIsTemporary, NewWidth, NewHeight); FBits := MapViewOfFile(FMapHandle, FILE_MAP_ALL_ACCESS, 0, 0, 0); if not Assigned(FBits) then raise Exception.Create(RCStrFailedToMapViewOfFile); if ClearBuffer then FillLongword(FBits[0], NewWidth * NewHeight, clBlack32); end; class procedure TMMFBackend.InitializeFileMapping(var MapHandle, MapFileHandle: THandle; var MapFileName: string); begin MapHandle := INVALID_HANDLE_VALUE; MapFileHandle := INVALID_HANDLE_VALUE; if MapFileName <> '' then ForceDirectories(IncludeTrailingPathDelimiter(ExtractFilePath(MapFileName))); end; class procedure TMMFBackend.DeinitializeFileMapping(MapHandle, MapFileHandle: THandle; const MapFileName: string); begin if MapFileName <> '' then begin CloseHandle(MapHandle); CloseHandle(MapFileHandle); if FileExists(MapFileName) then DeleteFile(MapFileName); end; end; class procedure TMMFBackend.CreateFileMapping(var MapHandle, MapFileHandle: THandle; var MapFileName: string; IsTemporary: Boolean; NewWidth, NewHeight: Integer); var Flags: Cardinal; {$IFDEF USE_GUIDS_IN_MMF} function GetTempFileName(const Prefix: string): string; var GUID: TGUID; begin repeat CoCreateGuid(GUID); Result := TempPath + Prefix + GUIDToString(GUID); until not FileExists(Result); end; {$ELSE} function GetTempFileName(const Prefix: string): string; var PC: PChar; begin PC := StrAlloc(MAX_PATH + 1); Windows.GetTempFileName(PChar(GetTempPath), PChar(Prefix), 0, PC); Result := string(PC); StrDispose(PC); end; {$ENDIF} begin // close previous handles if MapHandle <> INVALID_HANDLE_VALUE then begin CloseHandle(MapHandle); MapHandle := INVALID_HANDLE_VALUE; end; if MapFileHandle <> INVALID_HANDLE_VALUE then begin CloseHandle(MapFileHandle); MapHandle := INVALID_HANDLE_VALUE; end; // Do we want to use an external map file? if (MapFileName <> '') or IsTemporary then begin if MapFileName = '' then {$IFDEF HAS_NATIVEINT} MapFileName := GetTempFileName(IntToStr(NativeUInt(Self))); {$ELSE} MapFileName := GetTempFileName(IntToStr(Cardinal(Self))); {$ENDIF} // delete file if exists if FileExists(MapFileName) then DeleteFile(MapFileName); // open file if IsTemporary then Flags := FILE_ATTRIBUTE_TEMPORARY OR FILE_FLAG_DELETE_ON_CLOSE else Flags := FILE_ATTRIBUTE_NORMAL; MapFileHandle := CreateFile(PChar(MapFileName), GENERIC_READ or GENERIC_WRITE, 0, nil, CREATE_ALWAYS, Flags, 0); if MapFileHandle = INVALID_HANDLE_VALUE then begin if not IsTemporary then raise Exception.CreateFmt(RCStrFailedToCreateMapFile, [MapFileName]) else begin // Reset and fall back to allocating in the system's paging file... // delete file if exists if FileExists(MapFileName) then DeleteFile(MapFileName); MapFileName := ''; end; end; end else // use the system's paging file MapFileHandle := INVALID_HANDLE_VALUE; // create map MapHandle := Windows.CreateFileMapping(MapFileHandle, nil, PAGE_READWRITE, 0, NewWidth * NewHeight * 4, nil); if MapHandle = 0 then raise Exception.Create(RCStrFailedToMapFile); end; {$ENDIF} {$IFDEF Windows} initialization TempPath := IncludeTrailingPathDelimiter(GetTempPath); finalization TempPath := ''; {$ENDIF} end. |
Added src/graphics32/GR32_Backends_LCL_Carbon.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 | unit GR32_Backends_LCL_Carbon; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Backend Extension for Graphics32 * * The Initial Developer of the Original Code is * Felipe Monteiro de Carvalho <felipemonteiro.carvalho@gmail.com> * * Portions created by the Initial Developer are Copyright (C) 2007-2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses { RTL and LCL } LCLIntf, LCLType, types, Controls, SysUtils, Classes, Graphics, { Graphics 32 } GR32, GR32_Backends, GR32_Containers, GR32_Image, { Carbon bindings } MacOSAll, { Carbon lcl interface } CarbonCanvas, CarbonPrivate; const STR_GenericRGBProfilePath = '/System/Library/ColorSync/Profiles/Generic RGB Profile.icc'; type { TLCLBackend } TLCLBackend = class(TCustomBackend, IPaintSupport, IDeviceContextSupport, ITextSupport, IFontSupport, ICanvasSupport) private FFont: TFont; FCanvas: TCanvas; FOnFontChange: TNotifyEvent; FOnCanvasChange: TNotifyEvent; { Carbon specific variables } Stride: Integer; FWidth, FHeight: Cardinal; FProfile: CMProfileRef; FColorSpace: CGColorSpaceRef; FContext: CGContextRef; FCanvasHandle: TCarbonDeviceContext; { Functions to easely generate carbon structures } function GetCarbonRect(Left, Top, Width, Height: Integer): MacOSAll.Rect; function GetCGRect(Left, Top, Width, Height: Integer): MacOSAll.CGRect; overload; function GetCGRect(SrcRect: TRect): MacOSAll.CGRect; overload; protected { BITS_GETTER } function GetBits: PColor32Array; override; procedure InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); override; procedure FinalizeSurface; override; public constructor Create; override; destructor Destroy; override; procedure Changed; override; function Empty: Boolean; override; public { IPaintSupport } procedure ImageNeeded; procedure CheckPixmap; procedure DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); { IDeviceContextSupport } function GetHandle: HDC; procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload; procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload; procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; property Handle: HDC read GetHandle; { ITextSupport } procedure Textout(X, Y: Integer; const Text: string); overload; procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload; procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload; function TextExtent(const Text: string): TSize; procedure TextoutW(X, Y: Integer; const Text: Widestring); overload; procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload; procedure TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload; function TextExtentW(const Text: Widestring): TSize; { IFontSupport } function GetOnFontChange: TNotifyEvent; procedure SetOnFontChange(Handler: TNotifyEvent); function GetFont: TFont; procedure SetFont(const Font: TFont); procedure UpdateFont; property Font: TFont read GetFont write SetFont; property OnFontChange: TNotifyEvent read FOnFontChange write FOnFontChange; { ICanvasSupport } function GetCanvasChange: TNotifyEvent; procedure SetCanvasChange(Handler: TNotifyEvent); function GetCanvas: TCanvas; procedure DeleteCanvas; function CanvasAllocated: Boolean; property Canvas: TCanvas read GetCanvas; property OnCanvasChange: TNotifyEvent read GetCanvasChange write SetCanvasChange; end; implementation uses GR32_LowLevel; var StockFont: TFont; { TLCLBackend } function TLCLBackend.GetCarbonRect(Left, Top, Width, Height: Integer): MacOSAll.Rect; begin Result.Left := Left; Result.Top := Top; Result.Right := Left + Width; Result.Bottom := Top + Height; end; function TLCLBackend.GetCGRect(Left, Top, Width, Height: Integer): MacOSAll.CGRect; begin Result.Origin.X := Left; Result.Origin.Y := Top; Result.Size.Width := Width; Result.Size.Height := Height; end; function TLCLBackend.GetCGRect(SrcRect: TRect): MacOSAll.CGRect; begin Result.Origin.X := SrcRect.Left; Result.Origin.Y := SrcRect.Top; Result.Size.Width := SrcRect.Right - SrcRect.Left; Result.Size.Height := SrcRect.Bottom - SrcRect.Top; end; constructor TLCLBackend.Create; var loc: CMProfileLocation; status: OSStatus; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.Create]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} inherited; { Creates a standard font } FFont := TFont.Create; { Creates a generic color profile } loc.locType := cmPathBasedProfile; loc.u.pathLoc.path := STR_GenericRGBProfilePath; status := CMOpenProfile(FProfile, loc); if status <> noErr then raise Exception.Create('Couldn''t create the generic profile'); { Creates a generic color space } FColorSpace := CGColorSpaceCreateWithPlatformColorSpace(FProfile); if FColorSpace = nil then raise Exception.Create('Couldn''t create the generic RGB color space'); end; destructor TLCLBackend.Destroy; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.Destroy]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} { Deallocates the standard font } FFont.Free; { Closes the profile } CMCloseProfile(FProfile); inherited; end; function TLCLBackend.GetBits: PColor32Array; begin Result := FBits; end; procedure TLCLBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.InitializeSurface] BEGIN', ' Self: ', IntToHex(PtrUInt(Self), 8), ' NewWidth: ', NewWidth, ' NewHeight: ', NewHeight ); {$ENDIF} { We allocate our own memory for the image } Stride := NewWidth * 4; FBits := System.GetMem(NewHeight * Stride); if FBits = nil then raise Exception.Create('[TLCLBackend.InitializeSurface] ERROR FBits = nil'); { Creates a device context for our raw image area } FContext := CGBitmapContextCreate(FBits, NewWidth, NewHeight, 8, Stride, FColorSpace, kCGImageAlphaNoneSkipFirst or kCGBitmapByteOrder32Little); if FContext = nil then raise Exception.Create('[TLCLBackend.InitializeSurface] ERROR FContext = nil'); { flip and offset CTM to upper left corner } CGContextTranslateCTM(FContext, 0, NewHeight); CGContextScaleCTM(FContext, 1, -1); FWidth := NewWidth; FHeight := NewHeight; { clear the image } if ClearBuffer then FillLongword(FBits[0], NewWidth * NewHeight, clBlack32); {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.InitializeSurface] END'); {$ENDIF} end; procedure TLCLBackend.FinalizeSurface; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.FinalizeSurface]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if Assigned(FBits) then System.FreeMem(FBits); FBits := nil; if Assigned(FContext) then CGContextRelease(FContext); FContext := nil; end; procedure TLCLBackend.Changed; begin inherited; end; function TLCLBackend.Empty: Boolean; begin Result := (FContext = nil) or (FBits = nil); end; { IPaintSupport } procedure TLCLBackend.ImageNeeded; begin end; procedure TLCLBackend.CheckPixmap; begin end; procedure TLCLBackend.DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); var ImageRef: CGImageRef; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.DoPaint]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} { CGContextDrawImage is also possible, but it doesn't flip the image } ImageRef := CGBitmapContextCreateImage(FContext); try HIViewDrawCGImage( TCarbonDeviceContext(ACanvas.Handle).CGContext, GetCGRect(0, 0, FWidth, FHeight), imageRef); finally if Assigned(ImageRef) then CGImageRelease(ImageRef); end; end; { IDeviceContextSupport } function TLCLBackend.GetHandle: HDC; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.GetHandle]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then GetCanvas; Result := FCanvas.Handle; end; procedure TLCLBackend.Draw(const DstRect, SrcRect: TRect; hSrc: HDC); var original, subsection: CGImageRef; CGDstRect, CGSrcRect: CGRect; ExternalContext: CGContextRef; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.Draw]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} // Gets the external context if (hSrc = 0) then Exit; ExternalContext := TCarbonDeviceContext(hSrc).CGContext; // Converts the rectangles to CoreGraphics rectangles CGDstRect := GetCGRect(DstRect); CGSrcRect := GetCGRect(SrcRect); // Gets an image handle that represents the subsection original := CGBitmapContextCreateImage(ExternalContext); subsection := CGImageCreateWithImageInRect(original, CGSrcRect); CGImageRelease(original); { We need to make adjustments to the CTM so the painting is done correctly } CGContextSaveGState(FContext); try CGContextTranslateCTM(FContext, 0, FOwner.Height); CGContextScaleCTM(FContext, 1, -1); CGContextTranslateCTM(FContext, 0, -CGDstRect.origin.y); CGDstRect.origin.y := 0; { Draw the subsection } CGContextDrawImage(FContext, CGDstRect, subsection); finally { reset the CTM to the old values } CGContextRestoreGState(FContext); end; // Release the subsection CGImageRelease(subsection); end; procedure TLCLBackend.DrawTo(hDst: HDC; DstX, DstY: Integer); var DstRect, SrcRect: TRect; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.DrawTo]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} DstRect.Left := DstX; DstRect.Top := DstY; DstRect.Right := FOwner.Width + DstX; DstRect.Bottom := FOwner.Height + DstY; SrcRect.Left := 0; SrcRect.Top := 0; SrcRect.Right := FOwner.Width; SrcRect.Bottom := FOwner.Height; DrawTo(hDst, DstRect, SrcRect); end; procedure TLCLBackend.DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); var original, subsection: CGImageRef; CGDstRect, CGSrcRect: CGRect; ExternalContext: CGContextRef; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.DrawTo with rects]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} // Gets the external context if (hDst = 0) then Exit; ExternalContext := TCarbonDeviceContext(hDst).CGContext; // Converts the rectangles to CoreGraphics rectangles CGDstRect := GetCGRect(DstRect); CGSrcRect := GetCGRect(SrcRect); // Gets an image handle that represents the subsection original := CGBitmapContextCreateImage(FContext); subsection := CGImageCreateWithImageInRect(original, CGSrcRect); CGImageRelease(original); { We need to make adjustments to the CTM so the painting is done correctly } CGContextSaveGState(ExternalContext); try CGContextTranslateCTM(ExternalContext, 0, FOwner.Height); CGContextScaleCTM(ExternalContext, 1, -1); CGContextTranslateCTM(ExternalContext, 0, -CGDstRect.origin.y); CGDstRect.origin.y := 0; { Draw the subsection } CGContextDrawImage(ExternalContext, CGDstRect, subsection); finally { reset the CTM to the old values } CGContextRestoreGState(ExternalContext); end; // Release the subsection CGImageRelease(subsection); end; { ITextSupport } procedure TLCLBackend.Textout(X, Y: Integer; const Text: string); begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.Textout]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then GetCanvas; UpdateFont; if not FOwner.MeasuringMode then FCanvas.TextOut(X, Y, Text); FOwner.Changed; end; procedure TLCLBackend.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.Textout with ClipRect]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then GetCanvas; UpdateFont; LCLIntf.ExtTextOut(FCanvas.Handle, X, Y, ETO_CLIPPED, @ClipRect, PChar(Text), Length(Text), nil); end; procedure TLCLBackend.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.Textout with Flags]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then GetCanvas; UpdateFont; LCLIntf.DrawText(FCanvas.Handle, PChar(Text), Length(Text), DstRect, Flags); end; function TLCLBackend.TextExtent(const Text: string): TSize; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.TextExtent]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then GetCanvas; UpdateFont; Result := FCanvas.TextExtent(Text); end; { Carbon uses UTF-8, so all W functions are converted to UTF-8 ones } procedure TLCLBackend.TextoutW(X, Y: Integer; const Text: Widestring); begin TextOut(X, Y, Utf8Encode(Text)); end; procedure TLCLBackend.TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); begin TextOut(X, Y, ClipRect, Utf8Encode(Text)); end; procedure TLCLBackend.TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); begin TextOut(DstRect, Flags, Utf8Encode(Text)); end; function TLCLBackend.TextExtentW(const Text: Widestring): TSize; begin Result := TextExtent(Utf8Encode(Text)); end; { IFontSupport } function TLCLBackend.GetOnFontChange: TNotifyEvent; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.GetOnFontChange]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} Result := FFont.OnChange; end; procedure TLCLBackend.SetOnFontChange(Handler: TNotifyEvent); begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.SetOnFontChange]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} FFont.OnChange := Handler; end; function TLCLBackend.GetFont: TFont; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.GetFont]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} Result := FFont; end; procedure TLCLBackend.SetFont(const Font: TFont); begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.SetFont]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} FFont.Assign(Font); end; procedure TLCLBackend.UpdateFont; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.UpdateFont]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} FFont.OnChange := FOnFontChange; if Assigned(FCanvas) then FCanvas.Font := FFont; end; { ICanvasSupport } function TLCLBackend.GetCanvasChange: TNotifyEvent; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.GetCanvasChange]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} Result := FOnCanvasChange; end; procedure TLCLBackend.SetCanvasChange(Handler: TNotifyEvent); begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.SetCanvasChange]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} FOnCanvasChange := Handler; end; function TLCLBackend.GetCanvas: TCanvas; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.GetCanvas] BEGIN', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if FCanvas = nil then begin FCanvas := TCanvas.Create; FCanvasHandle := TCarbonDeviceContext.Create; FCanvasHandle.CGContext := FContext; FCanvas.Handle := HDC(FCanvasHandle); FCanvas.OnChange := FOnCanvasChange; FCanvas.Font := FFont; end; Result := FCanvas; {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.GetCanvas] END'); {$ENDIF} end; procedure TLCLBackend.DeleteCanvas; begin {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.DeleteCanvas]', ' Self: ', IntToHex(PtrUInt(Self), 8), ' FCanvas: ', PtrUInt(FCanvas)); {$ENDIF} if Assigned(FCanvas) then begin FCanvas.Handle := 0; FCanvas.Free; FCanvas := nil; end; end; function TLCLBackend.CanvasAllocated: Boolean; begin Result := (FCanvas <> nil); {$IFDEF VerboseGR32Carbon} WriteLn('[TLCLBackend.CanvasAllocated]', ' Self: ', IntToHex(PtrUInt(Self), 8), ' FCanvas: ', PtrUInt(FCanvas)); {$ENDIF} end; initialization StockFont := TFont.Create; finalization StockFont.Free; end. |
Added src/graphics32/GR32_Backends_LCL_CustomDrawn.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 | unit GR32_Backends_LCL_CustomDrawn; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Backend Extension for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * * Portions created by the Initial Developer are Copyright (C) 2007-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses { RTL and LCL } LCLIntf, LCLType, types, Controls, SysUtils, Classes, Graphics, { Graphics 32 } GR32, GR32_Backends, GR32_Containers, GR32_Image, { CustomDrawn bindings } GraphType, FPImage, IntfGraphics, LCLProc, CustomDrawnProc; type { TLCLBackend } TLCLBackend = class( TCustomBackend, IPaintSupport, ITextSupport, IFontSupport, IDeviceContextSupport, ICanvasSupport ) private FFont: TFont; FCanvas: TCanvas; FCanvasHandle: HDC; FOnFontChange: TNotifyEvent; FOnCanvasChange: TNotifyEvent; FWidth, FHeight: Cardinal; FRawImage: TRawImage; FBitmap: TBitmap; procedure CanvasChangedHandler(Sender: TObject); protected { BITS_GETTER } function GetBits: PColor32Array; override; procedure InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); override; procedure FinalizeSurface; override; public constructor Create; override; destructor Destroy; override; procedure Changed; override; function Empty: Boolean; override; public { IPaintSupport } procedure DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); procedure ImageNeeded; procedure CheckPixmap; { IDeviceContextSupport } function GetHandle: HDC; procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload; procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload; procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; property Handle: HDC read GetHandle; { ITextSupport } procedure Textout(X, Y: Integer; const Text: string); overload; procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload; procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload; function TextExtent(const Text: string): TSize; procedure TextoutW(X, Y: Integer; const Text: Widestring); overload; procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload; procedure TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload; function TextExtentW(const Text: Widestring): TSize; { IFontSupport } function GetOnFontChange: TNotifyEvent; procedure SetOnFontChange(Handler: TNotifyEvent); function GetFont: TFont; procedure SetFont(const Font: TFont); procedure UpdateFont; property Font: TFont read GetFont write SetFont; property OnFontChange: TNotifyEvent read FOnFontChange write FOnFontChange; { ICanvasSupport } function GetCanvasChange: TNotifyEvent; procedure SetCanvasChange(Handler: TNotifyEvent); function GetCanvas: TCanvas; procedure DeleteCanvas; function CanvasAllocated: Boolean; property Canvas: TCanvas read GetCanvas; property OnCanvasChange: TNotifyEvent read GetCanvasChange write SetCanvasChange; end; implementation uses GR32_LowLevel; { TLCLBackend } constructor TLCLBackend.Create; begin inherited; FBitmap := TBitmap.Create; FBitmap.Canvas.OnChange := CanvasChangedHandler; FFont := TFont.Create; end; destructor TLCLBackend.Destroy; begin inherited; FFont.Free; FBitmap.Free; end; procedure TLCLBackend.CanvasChangedHandler(Sender: TObject); begin if Assigned(FOnCanvasChange) then FOnCanvasChange(Sender); end; function TLCLBackend.GetBits: PColor32Array; begin Result := FBits; end; procedure TLCLBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); var CDBitmap: TCDBitmap; LazImage: TLazIntfImage; begin { We allocate our own memory for the image } FRawImage.Description.Init_BPP32_B8G8R8A8_BIO_TTB(NewWidth, NewHeight); FRawImage.CreateData(ClearBuffer); FBits := PColor32Array(FRawImage.Data); if FBits = nil then raise Exception.Create('[TLCLBackend.InitializeSurface] ERROR FBits = nil'); LazImage := TLazIntfImage.Create(FRawImage, False); CDBitmap := TCDBitmap.Create; CDBitmap.Image := LazImage; FBitmap.Handle := HBITMAP(CDBitmap); FWidth := NewWidth; FHeight := NewHeight; end; procedure TLCLBackend.FinalizeSurface; begin if Assigned(FBits) then begin FRawImage.FreeData; FBits := nil; FBitmap.Handle := HBITMAP(0); end; FBits := nil; end; procedure TLCLBackend.Changed; begin inherited; end; function TLCLBackend.Empty: Boolean; begin Result := FBits = nil; end; { IPaintSupport } procedure TLCLBackend.ImageNeeded; begin end; procedure TLCLBackend.CheckPixmap; begin end; procedure TLCLBackend.DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); begin ACanvas.Draw(0, 0, FBitmap); end; { IDeviceContextSupport } function TLCLBackend.GetHandle: HDC; begin Result := Canvas.Handle; end; procedure TLCLBackend.Draw(const DstRect, SrcRect: TRect; hSrc: HDC); begin StretchMaskBlt( Canvas.Handle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, hSrc, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, 0, 0, 0, Canvas.CopyMode ); end; procedure TLCLBackend.DrawTo(hDst: HDC; DstX, DstY: Integer); begin StretchMaskBlt( hDst, DstX, DstY, FWidth, FHeight, Canvas.Handle, 0, 0, FWidth, FHeight, 0, 0, 0, Canvas.CopyMode ); end; procedure TLCLBackend.DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); begin StretchMaskBlt( hDst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Canvas.Handle, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, 0, 0, 0, Canvas.CopyMode ); end; { ITextSupport } procedure TLCLBackend.Textout(X, Y: Integer; const Text: string); begin if not Assigned(FCanvas) then GetCanvas; UpdateFont; if not FOwner.MeasuringMode then FCanvas.TextOut(X, Y, Text); // FOwner.Changed(DstRect); end; procedure TLCLBackend.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); begin if not Assigned(FCanvas) then GetCanvas; UpdateFont; LCLIntf.ExtTextOut(FCanvas.Handle, X, Y, ETO_CLIPPED, @ClipRect, PChar(Text), Length(Text), nil); end; procedure TLCLBackend.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); begin UpdateFont; LCLIntf.DrawText(FCanvas.Handle, PChar(Text), Length(Text), DstRect, Flags); end; function TLCLBackend.TextExtent(const Text: string): TSize; begin if not Assigned(FCanvas) then GetCanvas; UpdateFont; Result := FCanvas.TextExtent(Text); end; procedure TLCLBackend.TextoutW(X, Y: Integer; const Text: Widestring); begin Canvas.TextOut(X, Y, Text); end; procedure TLCLBackend.TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); begin Canvas.ClipRect := ClipRect;; Canvas.TextOut(X, Y, Text); end; procedure TLCLBackend.TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); begin TextOut(DstRect, Flags, Text); end; function TLCLBackend.TextExtentW(const Text: Widestring): TSize; begin Result := TextExtent(Text); end; { IFontSupport } function TLCLBackend.GetOnFontChange: TNotifyEvent; begin Result := FFont.OnChange; end; procedure TLCLBackend.SetOnFontChange(Handler: TNotifyEvent); begin FFont.OnChange := Handler; end; function TLCLBackend.GetFont: TFont; begin Result := FFont; end; procedure TLCLBackend.SetFont(const Font: TFont); begin FFont.Assign(Font); end; procedure TLCLBackend.UpdateFont; begin FFont.OnChange := FOnFontChange; if Assigned(FCanvas) then FCanvas.Font := FFont; end; { ICanvasSupport } function TLCLBackend.GetCanvasChange: TNotifyEvent; begin Result := FOnCanvasChange; end; procedure TLCLBackend.SetCanvasChange(Handler: TNotifyEvent); begin FOnCanvasChange := Handler; end; function TLCLBackend.GetCanvas: TCanvas; begin Result := FBitmap.Canvas; end; procedure TLCLBackend.DeleteCanvas; begin end; function TLCLBackend.CanvasAllocated: Boolean; begin Result := (Canvas <> nil); end; end. |
Added src/graphics32/GR32_Backends_LCL_Gtk.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 | unit GR32_Backends_LCL_Gtk; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Backend Extension for Graphics32 * * The Initial Developer of the Original Code is * Felipe Monteiro de Carvalho <felipemonteiro.carvalho@gmail.com> * * Portions created by the Initial Developer are Copyright (C) 2007-2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} {$DEFINE VerboseGR32GTK} uses LCLIntf, LCLType, types, Controls, SysUtils, Classes, {$IFDEF LCLGtk2} gdk2, gtk2, gdk2pixbuf, glib2, gtk2Def, {$ELSE} gdk, gtk, gdkpixbuf, glib, gtkdef, {$ENDIF} Graphics, GR32, GR32_Backends, GR32_Containers, GR32_Image; type { TLCLBackend } TLCLBackend = class(TCustomBackend, IPaintSupport, ITextSupport, IFontSupport, ICanvasSupport) private FFont: TFont; FCanvas: TCanvas; FCanvasHandle: TGtkDeviceContext; FOnFontChange: TNotifyEvent; FOnCanvasChange: TNotifyEvent; { Gtk specific variables } FPixbuf: PGdkPixBuf; procedure CanvasChangedHandler(Sender: TObject); procedure FontChangedHandler(Sender: TObject); procedure CanvasChanged; procedure FontChanged; protected FFontHandle: HFont; FBitmapInfo: TBitmapInfo; FHDC: HDC; { BITS_GETTER } function GetBits: PColor32Array; override; procedure InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); override; procedure FinalizeSurface; override; public constructor Create; override; destructor Destroy; override; procedure Changed; override; function Empty: Boolean; override; public { IPaintSupport } procedure ImageNeeded; procedure CheckPixmap; procedure DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); { ITextSupport } procedure Textout(X, Y: Integer; const Text: string); overload; procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload; procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload; function TextExtent(const Text: string): TSize; procedure TextoutW(X, Y: Integer; const Text: Widestring); overload; procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload; procedure TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload; function TextExtentW(const Text: Widestring): TSize; { IDeviceContextSupport } function GetHandle: HDC; procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload; procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload; procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; property Handle: HDC read GetHandle; { IFontSupport } function GetOnFontChange: TNotifyEvent; procedure SetOnFontChange(Handler: TNotifyEvent); function GetFont: TFont; procedure SetFont(const Font: TFont); procedure UpdateFont; property Font: TFont read GetFont write SetFont; property OnFontChange: TNotifyEvent read FOnFontChange write FOnFontChange; { ICanvasSupport } function GetCanvasChange: TNotifyEvent; procedure SetCanvasChange(Handler: TNotifyEvent); function GetCanvas: TCanvas; procedure DeleteCanvas; function CanvasAllocated: Boolean; property Canvas: TCanvas read GetCanvas; property OnCanvasChange: TNotifyEvent read GetCanvasChange write SetCanvasChange; end; implementation uses GR32_LowLevel; resourcestring RCStrCannotAllocateMemory = 'Can''t allocate memory for the DIB'; RCStrCannotAllocateThePixBuf = 'Can''t allocate the Pixbuf'; var StockFont: TFont; { TLCLBackend } constructor TLCLBackend.Create; begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.Create]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} inherited; FFont := TFont.Create; FFont.OnChange := FontChangedHandler; end; destructor TLCLBackend.Destroy; begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.Destroy]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} DeleteCanvas; FFont.Free; inherited; end; function TLCLBackend.GetBits: PColor32Array; begin Result := FBits; end; procedure TLCLBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); var Stride: Integer; begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.InitializeSurface] BEGIN', ' Self: ', IntToHex(PtrUInt(Self), 8), ' NewWidth: ', NewWidth, ' NewHeight: ', NewHeight ); {$ENDIF} { We allocate our own memory for the image, because otherwise it's not guaranteed which Stride Gdk will use. } Stride := NewWidth * 4; FBits := GetMem(NewHeight * Stride); FHDC := CreateCompatibleDC(0); if FHDC = 0 then begin FBits := nil; raise Exception.Create(RCStrCannotCreateCompatibleDC); end; if FBits = nil then raise Exception.Create(RCStrCannotAllocateMemory); { We didn't pass a memory freeing function, so we will have to take care of that ourselves } FPixbuf := gdk_pixbuf_new_from_data(pguchar(FBits), GDK_COLORSPACE_RGB, True, 8, NewWidth, NewHeight, Stride, nil, nil); if FPixbuf = nil then raise Exception.Create(RCStrCannotAllocateThePixBuf); { clear the image } if ClearBuffer then FillLongword(FBits[0], NewWidth * NewHeight, clBlack32); {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.InitializeSurface] END'); {$ENDIF} end; procedure TLCLBackend.FinalizeSurface; begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.FinalizeSurface]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} {$IFDEF LCLGtk2} if Assigned(FPixbuf) then g_object_unref(FPixbuf); FPixbuf := nil; {$ELSE} if Assigned(FPixbuf) then gdk_pixbuf_unref(FPixbuf); FPixbuf := nil; {$ENDIF} if FHDC <> 0 then DeleteDC(FHDC); FHDC := 0; if Assigned(FBits) then FreeMem(FBits); FBits := nil; end; procedure TLCLBackend.Changed; begin if FCanvas <> nil then FCanvas.Handle := Self.Handle; inherited; end; procedure TLCLBackend.CanvasChanged; begin if Assigned(FOnCanvasChange) then FOnCanvasChange(Self); end; procedure TLCLBackend.FontChanged; begin if Assigned(FOnFontChange) then FOnFontChange(Self); end; function TLCLBackend.Empty: Boolean; begin Result := (FPixBuf = nil) or (FBits = nil); end; procedure TLCLBackend.FontChangedHandler(Sender: TObject); begin if FFontHandle <> 0 then begin // if Handle <> 0 then SelectObject(Handle, StockFont); FFontHandle := 0; end; FontChanged; end; procedure TLCLBackend.CanvasChangedHandler(Sender: TObject); begin CanvasChanged; end; { IPaintSupport } procedure TLCLBackend.ImageNeeded; begin end; procedure TLCLBackend.CheckPixmap; begin end; procedure TLCLBackend.DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.DoPaint]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} gdk_draw_rgb_32_image( TGtkDeviceContext(ACanvas.Handle).Drawable, TGtkDeviceContext(ACanvas.Handle).GC, 0, 0, ABuffer.Width, ABuffer.Height, GDK_RGB_DITHER_NORMAL, Pguchar(FBits), ABuffer.Width * 4 ); (* gdk_pixbuf_render_to_drawable( FPixbuf, TGtkDeviceContext(ACanvas.Handle).Drawable, TGtkDeviceContext(ACanvas.Handle).GC, 0, // src_x 0, // src_y 0, // dest_x 0, // dest_y ABuffer.Width, // width ABuffer.Height, // height GDK_RGB_DITHER_NONE, // dither 0, // x_dither 0); // y_dither *) end; { ITextSupport } procedure TLCLBackend.Textout(X, Y: Integer; const Text: string); begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.Textout]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then GetCanvas; UpdateFont; if not FOwner.MeasuringMode then FCanvas.TextOut(X, Y, Text); FOwner.Changed; end; procedure TLCLBackend.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.Textout with ClipRect]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then GetCanvas; UpdateFont; LCLIntf.ExtTextOut(FCanvas.Handle, X, Y, ETO_CLIPPED, @ClipRect, PChar(Text), Length(Text), nil); end; procedure TLCLBackend.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.Textout with Flags]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then GetCanvas; UpdateFont; LCLIntf.DrawText(FCanvas.Handle, PChar(Text), Length(Text), DstRect, Flags); end; function TLCLBackend.TextExtent(const Text: string): TSize; begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.TextExtent]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then GetCanvas; // UpdateFont; Result := FCanvas.TextExtent(Text); end; { Gtk uses UTF-8, so all W functions are converted to UTF-8 ones } procedure TLCLBackend.TextoutW(X, Y: Integer; const Text: Widestring); begin TextOut(X, Y, Utf8Encode(Text)); end; procedure TLCLBackend.TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); begin TextOut(X, Y, ClipRect, Utf8Encode(Text)); end; procedure TLCLBackend.TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); begin TextOut(DstRect, Flags, Utf8Encode(Text)); end; function TLCLBackend.TextExtentW(const Text: Widestring): TSize; begin Result := TextExtent(Utf8Encode(Text)); end; { IFontSupport } function TLCLBackend.GetOnFontChange: TNotifyEvent; begin Result := FOnFontChange; end; procedure TLCLBackend.SetOnFontChange(Handler: TNotifyEvent); begin FOnFontChange := Handler; end; function TLCLBackend.GetFont: TFont; begin Result := FFont; end; function TLCLBackend.GetHandle: HDC; begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.GetHandle]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then GetCanvas; Result := FCanvas.Handle; end; procedure TLCLBackend.SetFont(const Font: TFont); begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.SetFont]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} FFont.Assign(Font); end; procedure TLCLBackend.UpdateFont; begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.UpdateFont]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} FFontHandle := Font.Handle; FFont.OnChange := FOnFontChange; if Assigned(FCanvas) then FCanvas.Font := FFont; end; { IDeviceContextSupport } procedure TLCLBackend.Draw(const DstRect, SrcRect: TRect; hSrc: HDC); begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.Draw]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if FOwner.Empty then Exit; if not FOwner.MeasuringMode then LclIntf.StretchBlt(Handle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, hSrc, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, SRCCOPY); FOwner.Changed(DstRect); end; procedure TLCLBackend.DrawTo(hDst: HDC; DstX, DstY: Integer); begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.DrawTo]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} LclIntf.BitBlt(hDst, DstX, DstY, FOwner.Width, FOwner.Height, Handle, DstX, DstY, SRCCOPY); (* LclIntf.StretchDIBits( hDst, DstX, DstY, FOwner.Width, FOwner.Height, 0, 0, FOwner.Width, FOwner.Height, Bits, FBitmapInfo, DIB_RGB_COLORS, SRCCOPY); *) end; procedure TLCLBackend.DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.DrawTo with rects]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} LclIntf.StretchBlt(hDst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Handle, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, SRCCOPY); (* *) end; { ICanvasSupport } function TLCLBackend.GetCanvasChange: TNotifyEvent; begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.GetCanvasChange]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} Result := FOnCanvasChange; end; procedure TLCLBackend.SetCanvasChange(Handler: TNotifyEvent); begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.SetCanvasChange]', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} FOnCanvasChange := Handler; end; function TLCLBackend.GetCanvas: TCanvas; begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.GetCanvas] BEGIN', ' Self: ', IntToHex(PtrUInt(Self), 8)); {$ENDIF} if not Assigned(FCanvas) then begin FCanvas := TCanvas.Create; FCanvasHandle := TGtkDeviceContext.Create; FCanvas.Handle := HDC(FCanvasHandle); FCanvas.OnChange := CanvasChangedHandler; end; Result := FCanvas; end; procedure TLCLBackend.DeleteCanvas; begin {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.DeleteCanvas]', ' Self: ', IntToHex(PtrUInt(Self), 8), ' FCanvas: ', PtrUInt(FCanvas)); {$ENDIF} if Assigned(FCanvas) then begin FCanvas.Handle := 0; FCanvas.Free; FCanvas := nil; end; end; function TLCLBackend.CanvasAllocated: Boolean; begin Result := Assigned(FCanvas); {$IFDEF VerboseGR32GTK} WriteLn('[TLCLBackend.CanvasAllocated]', ' Self: ', IntToHex(PtrUInt(Self), 8), ' FCanvas: ', PtrUInt(FCanvas)); {$ENDIF} end; initialization StockFont := TFont.Create; finalization StockFont.Free; end. |
Added src/graphics32/GR32_Backends_LCL_Win.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 | unit GR32_Backends_LCL_Win; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Backend Extension for Graphics32 * * The Initial Developer of the Original Code is * Andre Beckedorf - metaException * Andre@metaException.de * * Portions created by the Initial Developer are Copyright (C) 2007-2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Christian Budde * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF LCLWin32} Windows, {$ENDIF} LCLIntf, LCLType, Types, Controls, SysUtils, Classes, Graphics, GR32, GR32_Backends, GR32_Backends_Generic, GR32_Containers, GR32_Image, GR32_Paths; type { TLCLBackend } { This backend uses the LCL to manage and provide the buffer and additional graphics sub system features. The backing buffer is kept in memory. } TLCLBackend = class(TCustomBackend, IPaintSupport, IBitmapContextSupport, IDeviceContextSupport, ITextSupport, IFontSupport, ITextToPathSupport, ICanvasSupport) private procedure FontChangedHandler(Sender: TObject); procedure CanvasChangedHandler(Sender: TObject); procedure CanvasChanged; procedure FontChanged; protected FBitmapInfo: TBitmapInfo; FBitmapHandle: HBITMAP; FHDC: HDC; FFont: TFont; FCanvas: TCanvas; FFontHandle: HFont; FMapHandle: THandle; FOnFontChange: TNotifyEvent; FOnCanvasChange: TNotifyEvent; procedure InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); override; procedure FinalizeSurface; override; procedure PrepareFileMapping(NewWidth, NewHeight: Integer); virtual; public constructor Create; override; destructor Destroy; override; procedure Changed; override; function Empty: Boolean; override; public { IPaintSupport } procedure ImageNeeded; procedure CheckPixmap; procedure DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); { IBitmapContextSupport } function GetBitmapInfo: TBitmapInfo; function GetBitmapHandle: THandle; property BitmapInfo: TBitmapInfo read GetBitmapInfo; property BitmapHandle: THandle read GetBitmapHandle; { IDeviceContextSupport } function GetHandle: HDC; procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload; procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload; procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; property Handle: HDC read GetHandle; { ITextSupport } procedure Textout(X, Y: Integer; const Text: string); overload; procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload; procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload; function TextExtent(const Text: string): TSize; procedure TextoutW(X, Y: Integer; const Text: Widestring); overload; procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload; procedure TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload; function TextExtentW(const Text: Widestring): TSize; { IFontSupport } function GetOnFontChange: TNotifyEvent; procedure SetOnFontChange(Handler: TNotifyEvent); function GetFont: TFont; procedure SetFont(const Font: TFont); procedure UpdateFont; property Font: TFont read GetFont write SetFont; property OnFontChange: TNotifyEvent read FOnFontChange write FOnFontChange; { ITextToPathSupport } procedure TextToPath(Path: TCustomPath; const X, Y: TFloat; const Text: WideString); overload; procedure TextToPath(Path: TCustomPath; const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal); overload; function MeasureText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; { ICanvasSupport } function GetCanvasChange: TNotifyEvent; procedure SetCanvasChange(Handler: TNotifyEvent); function GetCanvas: TCanvas; procedure DeleteCanvas; function CanvasAllocated: Boolean; property Canvas: TCanvas read GetCanvas; property OnCanvasChange: TNotifyEvent read GetCanvasChange write SetCanvasChange; end; { TLCLGDIMMFBackend } { Same as TGDIBackend but relies on memory mapped files or mapped swap space for the backing buffer. } TLCLMMFBackend = class(TLCLBackend) private FMapFileHandle: THandle; FMapIsTemporary: Boolean; FMapFileName: string; protected procedure PrepareFileMapping(NewWidth, NewHeight: Integer); override; public constructor Create(Owner: TBitmap32; IsTemporary: Boolean = True; const MapFileName: string = ''); virtual; destructor Destroy; override; end; { TGDIMemoryBackend } { A backend that keeps the backing buffer entirely in memory and offers IPaintSupport without allocating a GDI handle } TLCLMemoryBackend = class(TMemoryBackend, IPaintSupport, IDeviceContextSupport) private procedure DoPaintRect(ABuffer: TBitmap32; ARect: TRect; ACanvas: TCanvas); function GetHandle: HDC; // Dummy protected FBitmapInfo: TBitmapInfo; procedure InitializeSurface(NewWidth: Integer; NewHeight: Integer; ClearBuffer: Boolean); override; public constructor Create; override; { IPaintSupport } procedure ImageNeeded; procedure CheckPixmap; procedure DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); { IDeviceContextSupport } procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload; procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload; procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; end; implementation uses GR32_Text_LCL_Win; var StockFont: HFONT; { TLCLBackend } constructor TLCLBackend.Create; begin inherited; FillChar(FBitmapInfo, SizeOf(TBitmapInfo), 0); with FBitmapInfo.bmiHeader do begin biSize := SizeOf(TBitmapInfoHeader); biPlanes := 1; biBitCount := 32; biCompression := BI_RGB; end; FMapHandle := 0; FFont := TFont.Create; FFont.OnChange := FontChangedHandler; end; destructor TLCLBackend.Destroy; begin DeleteCanvas; FFont.Free; inherited; end; procedure TLCLBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); begin with FBitmapInfo.bmiHeader do begin biWidth := NewWidth; biHeight := -NewHeight; biSizeImage := NewWidth * NewHeight * 4; end; PrepareFileMapping(NewWidth, NewHeight); FBitmapHandle := LCLIntf.CreateDIBSection(0, FBitmapInfo, DIB_RGB_COLORS, Pointer(FBits), FMapHandle, 0); if FBits = nil then raise Exception.Create(RCStrCannotAllocateDIBHandle); FHDC := CreateCompatibleDC(0); if FHDC = 0 then begin DeleteObject(FBitmapHandle); FBitmapHandle := 0; FBits := nil; raise Exception.Create(RCStrCannotCreateCompatibleDC); end; if SelectObject(FHDC, FBitmapHandle) = 0 then begin DeleteDC(FHDC); DeleteObject(FBitmapHandle); FHDC := 0; FBitmapHandle := 0; FBits := nil; raise Exception.Create(RCStrCannotSelectAnObjectIntoDC); end; end; procedure TLCLBackend.FinalizeSurface; begin if FHDC <> 0 then DeleteDC(FHDC); FHDC := 0; if FBitmapHandle <> 0 then DeleteObject(FBitmapHandle); FBitmapHandle := 0; FBits := nil; end; procedure TLCLBackend.DeleteCanvas; begin if Assigned(FCanvas) then begin FCanvas.Handle := 0; FCanvas.Free; FCanvas := nil; end; end; procedure TLCLBackend.PrepareFileMapping(NewWidth, NewHeight: Integer); begin // to be implemented by descendants end; procedure TLCLBackend.Changed; begin if FCanvas <> nil then FCanvas.Handle := Self.Handle; inherited; end; procedure TLCLBackend.CanvasChanged; begin if Assigned(FOnCanvasChange) then FOnCanvasChange(Self); end; procedure TLCLBackend.FontChanged; begin if Assigned(FOnFontChange) then FOnFontChange(Self); end; function TLCLBackend.TextExtent(const Text: string): TSize; var DC: HDC; OldFont: HGDIOBJ; begin UpdateFont; Result.cX := 0; Result.cY := 0; if Handle <> 0 then GetTextExtentPoint32(Handle, PChar(Text), Length(Text), Result) else begin StockBitmap.Canvas.Lock; try DC := StockBitmap.Canvas.Handle; OldFont := SelectObject(DC, Font.Handle); GetTextExtentPoint32(DC, PChar(Text), Length(Text), Result); SelectObject(DC, OldFont); finally StockBitmap.Canvas.Unlock; end; end; end; function TLCLBackend.TextExtentW(const Text: Widestring): TSize; var DC: HDC; OldFont: HGDIOBJ; begin UpdateFont; Result.cX := 0; Result.cY := 0; if Handle <> 0 then GetTextExtentPoint32W(Handle, PWideChar(Text), Length(Text), Result) else begin StockBitmap.Canvas.Lock; try DC := StockBitmap.Canvas.Handle; OldFont := SelectObject(DC, Font.Handle); GetTextExtentPoint32W(DC, PWideChar(Text), Length(Text), Result); SelectObject(DC, OldFont); finally StockBitmap.Canvas.Unlock; end; end; end; procedure TLCLBackend.Textout(X, Y: Integer; const Text: string); var Extent: TSize; begin UpdateFont; if not FOwner.MeasuringMode then begin if FOwner.Clipping then ExtTextout(Handle, X, Y, ETO_CLIPPED, @FOwner.ClipRect, PChar(Text), Length(Text), nil) else ExtTextout(Handle, X, Y, 0, nil, PChar(Text), Length(Text), nil); end; Extent := TextExtent(Text); FOwner.Changed(MakeRect(X, Y, X + Extent.cx + 1, Y + Extent.cy + 1)); end; procedure TLCLBackend.TextoutW(X, Y: Integer; const Text: Widestring); var Extent: TSize; begin UpdateFont; if not FOwner.MeasuringMode then begin if FOwner.Clipping then ExtTextoutW(Handle, X, Y, ETO_CLIPPED, @FOwner.ClipRect, PWideChar(Text), Length(Text), nil) else ExtTextoutW(Handle, X, Y, 0, nil, PWideChar(Text), Length(Text), nil); end; Extent := TextExtentW(Text); FOwner.Changed(MakeRect(X, Y, X + Extent.cx + 1, Y + Extent.cy + 1)); end; procedure TLCLBackend.TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); var Extent: TSize; begin UpdateFont; if not FOwner.MeasuringMode then ExtTextoutW(Handle, X, Y, ETO_CLIPPED, @ClipRect, PWideChar(Text), Length(Text), nil); Extent := TextExtentW(Text); FOwner.Changed(MakeRect(X, Y, X + Extent.cx + 1, Y + Extent.cy + 1)); end; procedure TLCLBackend.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); var Extent: TSize; begin UpdateFont; if not FOwner.MeasuringMode then ExtTextout(Handle, X, Y, ETO_CLIPPED, @ClipRect, PChar(Text), Length(Text), nil); Extent := TextExtent(Text); FOwner.Changed(MakeRect(X, Y, X + Extent.cx + 1, Y + Extent.cy + 1)); end; procedure TLCLBackend.TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); begin UpdateFont; if not FOwner.MeasuringMode then DrawTextW(Handle, PWideChar(Text), Length(Text), DstRect, Flags); FOwner.Changed(DstRect); end; procedure TLCLBackend.UpdateFont; begin if (FFontHandle = 0) and (Handle <> 0) then begin SelectObject(Handle, Font.Handle); SetTextColor(Handle, ColorToRGB(Font.Color)); SetBkMode(Handle, TRANSPARENT); FFontHandle := Font.Handle; end else begin SelectObject(Handle, FFontHandle); SetTextColor(Handle, ColorToRGB(Font.Color)); SetBkMode(Handle, TRANSPARENT); end; end; procedure TLCLBackend.TextToPath(Path: TCustomPath; const X, Y: TFloat; const Text: WideString); var R: TFloatRect; begin R := FloatRect(X, Y, X, Y); GR32_Text_LCL_Win.TextToPath(Font.Handle, Path, R, Text, 0); end; procedure TLCLBackend.TextToPath(Path: TCustomPath; const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal); begin GR32_Text_LCL_Win.TextToPath(Font.Handle, Path, DstRect, Text, Flags); end; function TLCLBackend.MeasureText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; begin Result := GR32_Text_LCL_Win.MeasureText(Font.Handle, DstRect, Text, Flags); end; procedure TLCLBackend.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); begin UpdateFont; if not FOwner.MeasuringMode then DrawText(Handle, PChar(Text), Length(Text), DstRect, Flags); FOwner.Changed(DstRect); end; procedure TLCLBackend.DrawTo(hDst: HDC; DstX, DstY: Integer); begin Windows.BitBlt(hDst, DstX, DstY, FOwner.Width, FOwner.Height, Handle, 0, 0, SRCCOPY); (* StretchDIBits( hDst, DstX, DstY, FOwner.Width, FOwner.Height, 0, 0, FOwner.Width, FOwner.Height, Bits, FBitmapInfo, DIB_RGB_COLORS, SRCCOPY); *) end; procedure TLCLBackend.DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); begin Windows.StretchBlt(hDst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Handle, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, SRCCOPY); end; function TLCLBackend.GetBitmapHandle: THandle; begin Result := FBitmapHandle; end; function TLCLBackend.GetBitmapInfo: TBitmapInfo; begin Result := FBitmapInfo; end; function TLCLBackend.GetCanvas: TCanvas; begin if not Assigned(FCanvas) then begin FCanvas := TCanvas.Create; FCanvas.Handle := Handle; FCanvas.OnChange := CanvasChangedHandler; end; Result := FCanvas; end; function TLCLBackend.GetCanvasChange: TNotifyEvent; begin Result := FOnCanvasChange; end; function TLCLBackend.GetFont: TFont; begin Result := FFont; end; function TLCLBackend.GetHandle: HDC; begin Result := FHDC; end; function TLCLBackend.GetOnFontChange: TNotifyEvent; begin Result := FOnFontChange; end; procedure TLCLBackend.SetCanvasChange(Handler: TNotifyEvent); begin FOnCanvasChange := Handler; end; procedure TLCLBackend.SetFont(const Font: TFont); begin FFont.Assign(Font); FontChanged; end; procedure TLCLBackend.SetOnFontChange(Handler: TNotifyEvent); begin FOnFontChange := Handler; end; procedure TLCLBackend.Draw(const DstRect, SrcRect: TRect; hSrc: HDC); begin if FOwner.Empty then Exit; if not FOwner.MeasuringMode then Windows.StretchBlt(Handle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, hSrc, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, SRCCOPY); FOwner.Changed(DstRect); end; function TLCLBackend.CanvasAllocated: Boolean; begin Result := Assigned(FCanvas); end; function TLCLBackend.Empty: Boolean; begin Result := FBitmapHandle = 0; end; procedure TLCLBackend.FontChangedHandler(Sender: TObject); begin if FFontHandle <> 0 then begin if Handle <> 0 then SelectObject(Handle, StockFont); FFontHandle := 0; end; FontChanged; end; procedure TLCLBackend.CanvasChangedHandler(Sender: TObject); begin CanvasChanged; end; { IPaintSupport } procedure TLCLBackend.ImageNeeded; begin end; procedure TLCLBackend.CheckPixmap; begin end; procedure TLCLBackend.DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); var i: Integer; begin if AInvalidRects.Count > 0 then for i := 0 to AInvalidRects.Count - 1 do with AInvalidRects[i]^ do Windows.BitBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top, ABuffer.Handle, Left, Top, SRCCOPY) else with APaintBox.GetViewportRect do Windows.BitBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top, ABuffer.Handle, Left, Top, SRCCOPY); end; { TLCLMMFBackend } constructor TLCLMMFBackend.Create(Owner: TBitmap32; IsTemporary: Boolean = True; const MapFileName: string = ''); begin FMapFileName := MapFileName; FMapIsTemporary := IsTemporary; TMMFBackend.InitializeFileMapping(FMapHandle, FMapFileHandle, FMapFileName); inherited Create(Owner); end; destructor TLCLMMFBackend.Destroy; begin TMMFBackend.DeinitializeFileMapping(FMapHandle, FMapFileHandle, FMapFileName); inherited; end; procedure TLCLMMFBackend.PrepareFileMapping(NewWidth, NewHeight: Integer); begin TMMFBackend.CreateFileMapping(FMapHandle, FMapFileHandle, FMapFileName, FMapIsTemporary, NewWidth, NewHeight); end; { TLCLMemoryBackend } constructor TLCLMemoryBackend.Create; begin inherited; FillChar(FBitmapInfo, SizeOf(TBitmapInfo), 0); with FBitmapInfo.bmiHeader do begin biSize := SizeOf(TBitmapInfoHeader); biPlanes := 1; biBitCount := 32; biCompression := BI_RGB; biXPelsPerMeter := 96; biYPelsPerMeter := 96; biClrUsed := 0; end; end; procedure TLCLMemoryBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); begin inherited; with FBitmapInfo.bmiHeader do begin biWidth := NewWidth; biHeight := -NewHeight; end; end; procedure TLCLMemoryBackend.ImageNeeded; begin end; procedure TLCLMemoryBackend.CheckPixmap; begin end; procedure TLCLMemoryBackend.DoPaintRect(ABuffer: TBitmap32; ARect: TRect; ACanvas: TCanvas); var Bitmap : HBITMAP; DeviceContext : HDC; Buffer : Pointer; OldObject : HGDIOBJ; begin {$IFDEF LCLWin32} if SetDIBitsToDevice(ACanvas.Handle, ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top, ARect.Left, ARect.Top, 0, ARect.Bottom - ARect.Top, ABuffer.Bits, Windows.BITMAPINFO(FBitmapInfo), DIB_RGB_COLORS) = 0 then begin // create compatible device context DeviceContext := CreateCompatibleDC(ACanvas.Handle); if DeviceContext <> 0 then try Bitmap := CreateDIBSection(DeviceContext, FBitmapInfo, DIB_RGB_COLORS, Buffer, 0, 0); if Bitmap <> 0 then begin OldObject := SelectObject(DeviceContext, Bitmap); try Move(ABuffer.Bits^, Buffer^, FBitmapInfo.bmiHeader.biWidth * FBitmapInfo.bmiHeader.biHeight * SizeOf(Cardinal)); Windows.BitBlt(ACanvas.Handle, ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top, DeviceContext, 0, 0, SRCCOPY); finally if OldObject <> 0 then SelectObject(DeviceContext, OldObject); DeleteObject(Bitmap); end; end else raise Exception.Create(RCStrCannotCreateCompatibleDC); finally DeleteDC(DeviceContext); end; end; {$ELSE} raise Exception.Create('"SetDIBitsToDevice" is only included in windows unit!') {$ENDIF} end; procedure TLCLMemoryBackend.Draw(const DstRect, SrcRect: TRect; hSrc: HDC); begin if FOwner.Empty then Exit; if not FOwner.MeasuringMode then raise Exception.Create('Not yet supported!'); FOwner.Changed(DstRect); end; procedure TLCLMemoryBackend.DrawTo(hDst: HDC; DstX, DstY: Integer); var Bitmap: HBITMAP; DeviceContext: HDC; Buffer: Pointer; OldObject: HGDIOBJ; begin {$IFDEF LCLWin32} if SetDIBitsToDevice(hDst, DstX, DstY, FOwner.Width, FOwner.Height, 0, 0, 0, FOwner.Height, FBits, Windows.BITMAPINFO(FBitmapInfo), DIB_RGB_COLORS) = 0 then begin // create compatible device context DeviceContext := CreateCompatibleDC(hDst); if DeviceContext <> 0 then try Bitmap := CreateDIBSection(DeviceContext, FBitmapInfo, DIB_RGB_COLORS, Buffer, 0, 0); if Bitmap <> 0 then begin OldObject := SelectObject(DeviceContext, Bitmap); try Move(FBits^, Buffer^, FBitmapInfo.bmiHeader.biWidth * FBitmapInfo.bmiHeader.biHeight * SizeOf(Cardinal)); Windows.BitBlt(hDst, DstX, DstY, FOwner.Width, FOwner.Height, DeviceContext, 0, 0, SRCCOPY); finally if OldObject <> 0 then SelectObject(DeviceContext, OldObject); DeleteObject(Bitmap); end; end else raise Exception.Create('Can''t create compatible DC'''); finally DeleteDC(DeviceContext); end; end; {$ELSE} raise Exception.Create('"SetDIBitsToDevice" is only included in windows unit!') {$ENDIF} end; procedure TLCLMemoryBackend.DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); var Bitmap: HBITMAP; DeviceContext: HDC; Buffer: Pointer; OldObject: HGDIOBJ; begin {$IFDEF LCLWin32} if SetDIBitsToDevice(hDst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, SrcRect.Left, SrcRect.Top, 0, SrcRect.Bottom - SrcRect.Top, FBits, Windows.BITMAPINFO(FBitmapInfo), DIB_RGB_COLORS) = 0 then begin // create compatible device context DeviceContext := CreateCompatibleDC(hDst); if DeviceContext <> 0 then try Buffer := nil; Bitmap := CreateDIBSection(DeviceContext, FBitmapInfo, DIB_RGB_COLORS, Buffer, 0, 0); if Bitmap <> 0 then begin OldObject := SelectObject(DeviceContext, Bitmap); try Move(FBits^, Buffer^, FBitmapInfo.bmiHeader.biWidth * FBitmapInfo.bmiHeader.biHeight * SizeOf(Cardinal)); Windows.BitBlt(hDst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, DeviceContext, 0, 0, SRCCOPY); finally if OldObject <> 0 then SelectObject(DeviceContext, OldObject); DeleteObject(Bitmap); end; end else raise Exception.Create('Can''t create compatible DC'''); finally DeleteDC(DeviceContext); end; end; {$ELSE} raise Exception.Create('"SetDIBitsToDevice" is only included in windows unit!') {$ENDIF} end; function TLCLMemoryBackend.GetHandle: HDC; begin Result := 0; end; procedure TLCLMemoryBackend.DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); var i : Integer; begin if AInvalidRects.Count > 0 then for i := 0 to AInvalidRects.Count - 1 do DoPaintRect(ABuffer, AInvalidRects[i]^, ACanvas) else DoPaintRect(ABuffer, APaintBox.GetViewportRect, ACanvas); end; initialization StockFont := GetStockObject(SYSTEM_FONT); finalization end. |
Added src/graphics32/GR32_Backends_VCL.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 | unit GR32_Backends_VCL; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Backend Extension for Graphics32 * * The Initial Developer of the Original Code is * Andre Beckedorf - metaException * Andre@metaException.de * * Portions created by the Initial Developer are Copyright (C) 2007-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses SysUtils, Classes, Windows, Graphics, GR32, GR32_Backends, GR32_Containers, GR32_Image, GR32_Backends_Generic, GR32_Paths; type { TGDIBackend } { This backend is the default backend on Windows. It uses the GDI to manage and provide the buffer and additional graphics sub system features. The backing buffer is kept in memory. } TGDIBackend = class(TCustomBackend, IPaintSupport, IBitmapContextSupport, IDeviceContextSupport, ITextSupport, IFontSupport, ICanvasSupport, ITextToPathSupport) private procedure FontChangedHandler(Sender: TObject); procedure CanvasChangedHandler(Sender: TObject); procedure CanvasChanged; procedure FontChanged; protected FBitmapInfo: TBitmapInfo; FBitmapHandle: HBITMAP; FHDC: HDC; FFont: TFont; FCanvas: TCanvas; FFontHandle: HFont; FMapHandle: THandle; FOnFontChange: TNotifyEvent; FOnCanvasChange: TNotifyEvent; procedure InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); override; procedure FinalizeSurface; override; procedure PrepareFileMapping(NewWidth, NewHeight: Integer); virtual; public constructor Create; override; destructor Destroy; override; procedure Changed; override; function Empty: Boolean; override; public { IPaintSupport } procedure ImageNeeded; procedure CheckPixmap; procedure DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); { IBitmapContextSupport } function GetBitmapInfo: TBitmapInfo; function GetBitmapHandle: THandle; property BitmapInfo: TBitmapInfo read GetBitmapInfo; property BitmapHandle: THandle read GetBitmapHandle; { IDeviceContextSupport } function GetHandle: HDC; procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload; procedure DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer); overload; procedure DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect); overload; property Handle: HDC read GetHandle; { ITextSupport } procedure Textout(X, Y: Integer; const Text: string); overload; procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload; procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload; function TextExtent(const Text: string): TSize; procedure TextoutW(X, Y: Integer; const Text: Widestring); overload; procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload; procedure TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload; function TextExtentW(const Text: Widestring): TSize; { IFontSupport } function GetOnFontChange: TNotifyEvent; procedure SetOnFontChange(Handler: TNotifyEvent); function GetFont: TFont; procedure SetFont(const Font: TFont); procedure UpdateFont; property Font: TFont read GetFont write SetFont; property OnFontChange: TNotifyEvent read FOnFontChange write FOnFontChange; { ITextToPathSupport } procedure TextToPath(Path: TCustomPath; const X, Y: TFloat; const Text: WideString); overload; procedure TextToPath(Path: TCustomPath; const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal); overload; function MeasureText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; { ICanvasSupport } function GetCanvasChange: TNotifyEvent; procedure SetCanvasChange(Handler: TNotifyEvent); function GetCanvas: TCanvas; procedure DeleteCanvas; function CanvasAllocated: Boolean; property Canvas: TCanvas read GetCanvas; property OnCanvasChange: TNotifyEvent read GetCanvasChange write SetCanvasChange; end; { TGDIMMFBackend } { Same as TGDIBackend but relies on memory mapped files or mapped swap space for the backing buffer. } TGDIMMFBackend = class(TGDIBackend) private FMapFileHandle: THandle; FMapIsTemporary: Boolean; FMapFileName: string; protected procedure PrepareFileMapping(NewWidth, NewHeight: Integer); override; public constructor Create(Owner: TBitmap32; IsTemporary: Boolean = True; const MapFileName: string = ''); virtual; destructor Destroy; override; end; { TGDIMemoryBackend } { A backend that keeps the backing buffer entirely in memory and offers IPaintSupport without allocating a GDI handle } TGDIMemoryBackend = class(TMemoryBackend, IPaintSupport, IDeviceContextSupport) private procedure DoPaintRect(ABuffer: TBitmap32; ARect: TRect; ACanvas: TCanvas); function GetHandle: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; // Dummy protected FBitmapInfo: TBitmapInfo; procedure InitializeSurface(NewWidth: Integer; NewHeight: Integer; ClearBuffer: Boolean); override; public constructor Create; override; { IPaintSupport } procedure ImageNeeded; procedure CheckPixmap; procedure DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); { IDeviceContextSupport } procedure Draw(const DstRect, SrcRect: TRect; hSrc: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}); overload; procedure DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer); overload; procedure DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect); overload; end; implementation uses GR32_Text_VCL; var StockFont: HFONT; { TGDIBackend } constructor TGDIBackend.Create; begin inherited; FillChar(FBitmapInfo, SizeOf(TBitmapInfo), 0); with FBitmapInfo.bmiHeader do begin biSize := SizeOf(TBitmapInfoHeader); biPlanes := 1; biBitCount := 32; biCompression := BI_RGB; end; FMapHandle := 0; FFont := TFont.Create; FFont.OnChange := FontChangedHandler; FFont.OwnerCriticalSection := @FLock; end; destructor TGDIBackend.Destroy; begin DeleteCanvas; FFont.Free; inherited; end; procedure TGDIBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); begin with FBitmapInfo.bmiHeader do begin biWidth := NewWidth; biHeight := -NewHeight; biSizeImage := NewWidth * NewHeight * 4; end; PrepareFileMapping(NewWidth, NewHeight); FBitmapHandle := CreateDIBSection(0, FBitmapInfo, DIB_RGB_COLORS, Pointer(FBits), FMapHandle, 0); if FBits = nil then raise EBackend.Create(RCStrCannotAllocateDIBHandle); FHDC := CreateCompatibleDC(0); if FHDC = 0 then begin DeleteObject(FBitmapHandle); FBitmapHandle := 0; FBits := nil; raise EBackend.Create(RCStrCannotCreateCompatibleDC); end; if SelectObject(FHDC, FBitmapHandle) = 0 then begin DeleteDC(FHDC); DeleteObject(FBitmapHandle); FHDC := 0; FBitmapHandle := 0; FBits := nil; raise EBackend.Create(RCStrCannotSelectAnObjectIntoDC); end; end; function TGDIBackend.MeasureText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; begin Result := GR32_Text_VCL.MeasureText(Font.Handle, DstRect, Text, Flags); end; procedure TGDIBackend.FinalizeSurface; begin if FHDC <> 0 then DeleteDC(FHDC); FHDC := 0; if FBitmapHandle <> 0 then DeleteObject(FBitmapHandle); FBitmapHandle := 0; FBits := nil; end; procedure TGDIBackend.DeleteCanvas; begin if Assigned(FCanvas) then begin FCanvas.Handle := 0; FCanvas.Free; FCanvas := nil; end; end; procedure TGDIBackend.PrepareFileMapping(NewWidth, NewHeight: Integer); begin // to be implemented by descendants end; procedure TGDIBackend.Changed; begin if FCanvas <> nil then FCanvas.Handle := Self.Handle; inherited; end; procedure TGDIBackend.CanvasChanged; begin if Assigned(FOnCanvasChange) then FOnCanvasChange(Self); end; procedure TGDIBackend.FontChanged; begin if Assigned(FOnFontChange) then FOnFontChange(Self); end; function TGDIBackend.TextExtent(const Text: string): TSize; var DC: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; OldFont: HGDIOBJ; begin UpdateFont; Result.cX := 0; Result.cY := 0; if Handle <> 0 then Windows.GetTextExtentPoint32(Handle, PChar(Text), Length(Text), Result) else begin StockBitmap.Canvas.Lock; try DC := StockBitmap.Canvas.Handle; OldFont := SelectObject(DC, Font.Handle); Windows.GetTextExtentPoint32(DC, PChar(Text), Length(Text), Result); SelectObject(DC, OldFont); finally StockBitmap.Canvas.Unlock; end; end; end; function TGDIBackend.TextExtentW(const Text: Widestring): TSize; var DC: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; OldFont: HGDIOBJ; begin UpdateFont; Result.cX := 0; Result.cY := 0; if Handle <> 0 then Windows.GetTextExtentPoint32W(Handle, PWideChar(Text), Length(Text), Result) else begin StockBitmap.Canvas.Lock; try DC := StockBitmap.Canvas.Handle; OldFont := SelectObject(DC, Font.Handle); Windows.GetTextExtentPoint32W(DC, PWideChar(Text), Length(Text), Result); SelectObject(DC, OldFont); finally StockBitmap.Canvas.Unlock; end; end; end; procedure TGDIBackend.Textout(X, Y: Integer; const Text: string); var Extent: TSize; begin UpdateFont; if not FOwner.MeasuringMode then begin if FOwner.Clipping then ExtTextout(Handle, X, Y, ETO_CLIPPED, @FOwner.ClipRect, PChar(Text), Length(Text), nil) else ExtTextout(Handle, X, Y, 0, nil, PChar(Text), Length(Text), nil); end; Extent := TextExtent(Text); FOwner.Changed(MakeRect(X, Y, X + Extent.cx + 1, Y + Extent.cy + 1)); end; procedure TGDIBackend.TextoutW(X, Y: Integer; const Text: Widestring); var Extent: TSize; begin UpdateFont; if not FOwner.MeasuringMode then begin if FOwner.Clipping then ExtTextoutW(Handle, X, Y, ETO_CLIPPED, @FOwner.ClipRect, PWideChar(Text), Length(Text), nil) else ExtTextoutW(Handle, X, Y, 0, nil, PWideChar(Text), Length(Text), nil); end; Extent := TextExtentW(Text); FOwner.Changed(MakeRect(X, Y, X + Extent.cx + 1, Y + Extent.cy + 1)); end; procedure TGDIBackend.TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); var Extent: TSize; begin UpdateFont; if not FOwner.MeasuringMode then ExtTextoutW(Handle, X, Y, ETO_CLIPPED, @ClipRect, PWideChar(Text), Length(Text), nil); Extent := TextExtentW(Text); FOwner.Changed(MakeRect(X, Y, X + Extent.cx + 1, Y + Extent.cy + 1)); end; procedure TGDIBackend.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); var Extent: TSize; begin UpdateFont; if not FOwner.MeasuringMode then ExtTextout(Handle, X, Y, ETO_CLIPPED, @ClipRect, PChar(Text), Length(Text), nil); Extent := TextExtent(Text); FOwner.Changed(MakeRect(X, Y, X + Extent.cx + 1, Y + Extent.cy + 1)); end; procedure TGDIBackend.TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); begin UpdateFont; if not FOwner.MeasuringMode then DrawTextW(Handle, PWideChar(Text), Length(Text), DstRect, Flags); FOwner.Changed(DstRect); end; procedure TGDIBackend.TextToPath(Path: TCustomPath; const X, Y: TFloat; const Text: WideString); var R: TFloatRect; begin R := FloatRect(X, Y, X, Y); GR32_Text_VCL.TextToPath(Font.Handle, Path, R, Text, 0); end; procedure TGDIBackend.TextToPath(Path: TCustomPath; const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal); begin GR32_Text_VCL.TextToPath(Font.Handle, Path, DstRect, Text, Flags); end; procedure TGDIBackend.UpdateFont; begin if (FFontHandle = 0) and (Handle <> 0) then begin SelectObject(Handle, Font.Handle); SetTextColor(Handle, ColorToRGB(Font.Color)); SetBkMode(Handle, Windows.TRANSPARENT); FFontHandle := Font.Handle; end else begin SelectObject(Handle, FFontHandle); SetTextColor(Handle, ColorToRGB(Font.Color)); SetBkMode(Handle, Windows.TRANSPARENT); end; end; procedure TGDIBackend.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); begin UpdateFont; if not FOwner.MeasuringMode then DrawText(Handle, PChar(Text), Length(Text), DstRect, Flags); FOwner.Changed(DstRect); end; procedure TGDIBackend.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer); begin StretchDIBits( hDst, DstX, DstY, FOwner.Width, FOwner.Height, 0, 0, FOwner.Width, FOwner.Height, Bits, FBitmapInfo, DIB_RGB_COLORS, SRCCOPY); end; procedure TGDIBackend.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect); begin StretchBlt( hDst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Handle, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, SRCCOPY); end; function TGDIBackend.GetBitmapHandle: THandle; begin Result := FBitmapHandle; end; function TGDIBackend.GetBitmapInfo: TBitmapInfo; begin Result := FBitmapInfo; end; function TGDIBackend.GetCanvas: TCanvas; begin if not Assigned(FCanvas) then begin FCanvas := TCanvas.Create; FCanvas.Handle := Handle; FCanvas.OnChange := CanvasChangedHandler; end; Result := FCanvas; end; function TGDIBackend.GetCanvasChange: TNotifyEvent; begin Result := FOnCanvasChange; end; function TGDIBackend.GetFont: TFont; begin Result := FFont; end; function TGDIBackend.GetHandle: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; begin Result := FHDC; end; function TGDIBackend.GetOnFontChange: TNotifyEvent; begin Result := FOnFontChange; end; procedure TGDIBackend.SetCanvasChange(Handler: TNotifyEvent); begin FOnCanvasChange := Handler; end; procedure TGDIBackend.SetFont(const Font: TFont); begin FFont.Assign(Font); FontChanged; end; procedure TGDIBackend.SetOnFontChange(Handler: TNotifyEvent); begin FOnFontChange := Handler; end; procedure TGDIBackend.Draw(const DstRect, SrcRect: TRect; hSrc: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}); begin if FOwner.Empty then Exit; if not FOwner.MeasuringMode then StretchBlt(Handle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, hSrc, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, SRCCOPY); FOwner.Changed(DstRect); end; function TGDIBackend.CanvasAllocated: Boolean; begin Result := Assigned(FCanvas); end; function TGDIBackend.Empty: Boolean; begin Result := FBitmapHandle = 0; end; procedure TGDIBackend.FontChangedHandler(Sender: TObject); begin if FFontHandle <> 0 then begin if Handle <> 0 then SelectObject(Handle, StockFont); FFontHandle := 0; end; FontChanged; end; procedure TGDIBackend.CanvasChangedHandler(Sender: TObject); begin CanvasChanged; end; { IPaintSupport } procedure TGDIBackend.ImageNeeded; begin end; procedure TGDIBackend.CheckPixmap; begin end; procedure TGDIBackend.DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); var i: Integer; begin if AInvalidRects.Count > 0 then for i := 0 to AInvalidRects.Count - 1 do with AInvalidRects[i]^ do BitBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top, ABuffer.Handle, Left, Top, SRCCOPY) else with APaintBox.GetViewportRect do BitBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top, ABuffer.Handle, Left, Top, SRCCOPY); end; { TGDIMMFBackend } constructor TGDIMMFBackend.Create(Owner: TBitmap32; IsTemporary: Boolean = True; const MapFileName: string = ''); begin FMapFileName := MapFileName; FMapIsTemporary := IsTemporary; TMMFBackend.InitializeFileMapping(FMapHandle, FMapFileHandle, FMapFileName); inherited Create(Owner); end; destructor TGDIMMFBackend.Destroy; begin TMMFBackend.DeinitializeFileMapping(FMapHandle, FMapFileHandle, FMapFileName); inherited; end; procedure TGDIMMFBackend.PrepareFileMapping(NewWidth, NewHeight: Integer); begin TMMFBackend.CreateFileMapping(FMapHandle, FMapFileHandle, FMapFileName, FMapIsTemporary, NewWidth, NewHeight); end; { TGDIMemoryBackend } constructor TGDIMemoryBackend.Create; begin inherited; FillChar(FBitmapInfo, SizeOf(TBitmapInfo), 0); with FBitmapInfo.bmiHeader do begin biSize := SizeOf(TBitmapInfoHeader); biPlanes := 1; biBitCount := 32; biCompression := BI_RGB; biXPelsPerMeter := 96; biYPelsPerMeter := 96; biClrUsed := 0; end; end; procedure TGDIMemoryBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); begin inherited; with FBitmapInfo.bmiHeader do begin biWidth := NewWidth; biHeight := -NewHeight; end; end; procedure TGDIMemoryBackend.ImageNeeded; begin end; procedure TGDIMemoryBackend.CheckPixmap; begin end; procedure TGDIMemoryBackend.DoPaintRect(ABuffer: TBitmap32; ARect: TRect; ACanvas: TCanvas); var Bitmap : HBITMAP; DeviceContext : {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; Buffer : Pointer; OldObject : HGDIOBJ; begin if SetDIBitsToDevice(ACanvas.Handle, ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top, ARect.Left, ARect.Top, 0, ARect.Bottom - ARect.Top, ABuffer.Bits, FBitmapInfo, DIB_RGB_COLORS) = 0 then begin // create compatible device context DeviceContext := CreateCompatibleDC(ACanvas.Handle); if DeviceContext <> 0 then try Bitmap := CreateDIBSection(DeviceContext, FBitmapInfo, DIB_RGB_COLORS, Buffer, 0, 0); if Bitmap <> 0 then begin OldObject := SelectObject(DeviceContext, Bitmap); try Move(ABuffer.Bits^, Buffer^, FBitmapInfo.bmiHeader.biWidth * FBitmapInfo.bmiHeader.biHeight * SizeOf(Cardinal)); BitBlt(ACanvas.Handle, ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top, DeviceContext, 0, 0, SRCCOPY); finally if OldObject <> 0 then SelectObject(DeviceContext, OldObject); DeleteObject(Bitmap); end; end else raise EBackend.Create(RCStrCannotCreateCompatibleDC); finally DeleteDC(DeviceContext); end; end; end; procedure TGDIMemoryBackend.Draw(const DstRect, SrcRect: TRect; hSrc: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}); begin if FOwner.Empty then Exit; if not FOwner.MeasuringMode then raise EBackend.Create('Not supported!'); FOwner.Changed(DstRect); end; procedure TGDIMemoryBackend.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer); var Bitmap : HBITMAP; DeviceContext : {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; Buffer : Pointer; OldObject : HGDIOBJ; begin if SetDIBitsToDevice(hDst, DstX, DstY, FOwner.Width, FOwner.Height, 0, 0, 0, FOwner.Height, FBits, FBitmapInfo, DIB_RGB_COLORS) = 0 then begin // create compatible device context DeviceContext := CreateCompatibleDC(hDst); if DeviceContext <> 0 then try Bitmap := CreateDIBSection(DeviceContext, FBitmapInfo, DIB_RGB_COLORS, Buffer, 0, 0); if Bitmap <> 0 then begin OldObject := SelectObject(DeviceContext, Bitmap); try Move(FBits^, Buffer^, FBitmapInfo.bmiHeader.biWidth * FBitmapInfo.bmiHeader.biHeight * SizeOf(Cardinal)); BitBlt(hDst, DstX, DstY, FOwner.Width, FOwner.Height, DeviceContext, 0, 0, SRCCOPY); finally if OldObject <> 0 then SelectObject(DeviceContext, OldObject); DeleteObject(Bitmap); end; end else raise EBackend.Create(RCStrCannotCreateCompatibleDC); finally DeleteDC(DeviceContext); end; end; end; procedure TGDIMemoryBackend.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect); var Bitmap : HBITMAP; DeviceContext : {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; Buffer : Pointer; OldObject : HGDIOBJ; begin if SetDIBitsToDevice(hDst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, SrcRect.Left, SrcRect.Top, 0, SrcRect.Bottom - SrcRect.Top, FBits, FBitmapInfo, DIB_RGB_COLORS) = 0 then begin // create compatible device context DeviceContext := CreateCompatibleDC(hDst); if DeviceContext <> 0 then try Bitmap := CreateDIBSection(DeviceContext, FBitmapInfo, DIB_RGB_COLORS, Buffer, 0, 0); if Bitmap <> 0 then begin OldObject := SelectObject(DeviceContext, Bitmap); try Move(FBits^, Buffer^, FBitmapInfo.bmiHeader.biWidth * FBitmapInfo.bmiHeader.biHeight * SizeOf(Cardinal)); BitBlt(hDst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, DeviceContext, 0, 0, SRCCOPY); finally if OldObject <> 0 then SelectObject(DeviceContext, OldObject); DeleteObject(Bitmap); end; end else raise EBackend.Create(RCStrCannotCreateCompatibleDC); finally DeleteDC(DeviceContext); end; end; end; function TGDIMemoryBackend.GetHandle: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; begin Result := 0; end; procedure TGDIMemoryBackend.DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32); var i : Integer; begin if AInvalidRects.Count > 0 then for i := 0 to AInvalidRects.Count - 1 do DoPaintRect(ABuffer, AInvalidRects[i]^, ACanvas) else DoPaintRect(ABuffer, APaintBox.GetViewportRect, ACanvas); end; initialization StockFont := GetStockObject(SYSTEM_FONT); finalization end. |
Added src/graphics32/GR32_Bindings.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | unit GR32_Bindings; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Run-time Function Bindings for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson * mattias@centaurix.com * * Portions created by the Initial Developer are Copyright (C) 2005-2010 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Classes, GR32_System; type TFunctionName = type string; TFunctionID = type Integer; PFunctionInfo = ^TFunctionInfo; TFunctionInfo = record FunctionID: Integer; Proc: Pointer; CPUFeatures: TCPUFeatures; Flags: Integer; end; TFunctionPriority = function (Info: PFunctionInfo): Integer; PFunctionBinding = ^TFunctionBinding; TFunctionBinding = record FunctionID: Integer; BindVariable: PPointer; end; { TFunctionRegistry } { This class fascilitates a registry that allows multiple function to be registered together with information about their CPU requirements and an additional 'flags' parameter. Functions that share the same FunctionID can be assigned to a function variable through the rebind methods. A priority callback function is used to assess the most optimal function. } TFunctionRegistry = class(TPersistent) private FItems: TList; FBindings: TList; FName: string; procedure SetName(const Value: string); function GetItems(Index: Integer): PFunctionInfo; procedure SetItems(Index: Integer; const Value: PFunctionInfo); public constructor Create; virtual; destructor Destroy; override; procedure Clear; procedure Add(FunctionID: Integer; Proc: Pointer; CPUFeatures: TCPUFeatures = []; Flags: Integer = 0); // function rebinding support procedure RegisterBinding(FunctionID: Integer; BindVariable: PPointer); procedure RebindAll(PriorityCallback: TFunctionPriority = nil); procedure Rebind(FunctionID: Integer; PriorityCallback: TFunctionPriority = nil); function FindFunction(FunctionID: Integer; PriorityCallback: TFunctionPriority = nil): Pointer; property Items[Index: Integer]: PFunctionInfo read GetItems write SetItems; published property Name: string read FName write SetName; end; function NewRegistry(const Name: string = ''): TFunctionRegistry; function DefaultPriorityProc(Info: PFunctionInfo): Integer; var DefaultPriority: TFunctionPriority = DefaultPriorityProc; const INVALID_PRIORITY: Integer = MaxInt; implementation uses Math; var Registers: TList; function NewRegistry(const Name: string): TFunctionRegistry; begin if Registers = nil then Registers := TList.Create; Result := TFunctionRegistry.Create; Result.Name := Name; Registers.Add(Result); end; function DefaultPriorityProc(Info: PFunctionInfo): Integer; begin Result := IfThen(Info^.CPUFeatures <= GR32_System.CPUFeatures, 0, INVALID_PRIORITY); end; { TFunctionRegistry } procedure TFunctionRegistry.Add(FunctionID: Integer; Proc: Pointer; CPUFeatures: TCPUFeatures; Flags: Integer); var Info: PFunctionInfo; begin New(Info); Info^.FunctionID := FunctionID; Info^.Proc := Proc; Info^.CPUFeatures := CPUFeatures; Info^.Flags := Flags; FItems.Add(Info); end; procedure TFunctionRegistry.Clear; var I: Integer; begin for I := 0 to FItems.Count - 1 do Dispose(PFunctionInfo(FItems[I])); FItems.Clear; for I := 0 to FBindings.Count - 1 do Dispose(PFunctionBinding(FBindings[I])); FBindings.Clear; end; constructor TFunctionRegistry.Create; begin FItems := TList.Create; FBindings := TList.Create; end; destructor TFunctionRegistry.Destroy; begin Clear; FItems.Free; FBindings.Free; inherited; end; function TFunctionRegistry.FindFunction(FunctionID: Integer; PriorityCallback: TFunctionPriority): Pointer; var I, MinPriority, P: Integer; Info: PFunctionInfo; begin if not Assigned(PriorityCallback) then PriorityCallback := DefaultPriority; Result := nil; MinPriority := INVALID_PRIORITY; for I := FItems.Count - 1 downto 0 do begin Info := FItems[I]; if (Info^.FunctionID = FunctionID) then begin P := PriorityCallback(Info); if P < MinPriority then begin Result := Info^.Proc; MinPriority := P; end; end; end; end; function TFunctionRegistry.GetItems(Index: Integer): PFunctionInfo; begin Result := FItems[Index]; end; procedure TFunctionRegistry.Rebind(FunctionID: Integer; PriorityCallback: TFunctionPriority); var P: PFunctionBinding; I: Integer; begin for I := 0 to FBindings.Count - 1 do begin P := PFunctionBinding(FBindings[I]); if P^.FunctionID = FunctionID then P^.BindVariable^ := FindFunction(FunctionID, PriorityCallback); end; end; procedure TFunctionRegistry.RebindAll(PriorityCallback: TFunctionPriority); var I: Integer; P: PFunctionBinding; begin for I := 0 to FBindings.Count - 1 do begin P := PFunctionBinding(FBindings[I]); P^.BindVariable^ := FindFunction(P^.FunctionID, PriorityCallback); end; end; procedure TFunctionRegistry.RegisterBinding(FunctionID: Integer; BindVariable: PPointer); var Binding: PFunctionBinding; begin New(Binding); Binding^.FunctionID := FunctionID; Binding^.BindVariable := BindVariable; FBindings.Add(Binding); end; procedure TFunctionRegistry.SetItems(Index: Integer; const Value: PFunctionInfo); begin FItems[Index] := Value; end; procedure TFunctionRegistry.SetName(const Value: string); begin FName := Value; end; procedure FreeRegisters; var I: Integer; begin if Assigned(Registers) then begin for I := Registers.Count - 1 downto 0 do TFunctionRegistry(Registers[I]).Free; Registers.Free; Registers := nil; end; end; initialization finalization FreeRegisters; end. |
Added src/graphics32/GR32_Blend.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 | unit GR32_Blend; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Mattias Andersson * - 2004/07/07 - MMX Blendmodes * - 2004/12/10 - _MergeReg, M_MergeReg * * Michael Hansen <dyster_tid@hotmail.com> * - 2004/07/07 - Pascal Blendmodes, function setup * - 2005/08/19 - New merge table concept and reference implementations * * Bob Voigt * - 2004/08/25 - ColorDiv * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses GR32, GR32_Bindings, SysUtils; var MMX_ACTIVE: Boolean; type { Function Prototypes } TBlendReg = function(F, B: TColor32): TColor32; TBlendMem = procedure(F: TColor32; var B: TColor32); TBlendMems = procedure(F: TColor32; B: PColor32; Count: Integer); TBlendRegEx = function(F, B, M: TColor32): TColor32; TBlendMemEx = procedure(F: TColor32; var B: TColor32; M: TColor32); TBlendRegRGB = function(F, B, W: TColor32): TColor32; TBlendMemRGB = procedure(F: TColor32; var B: TColor32; W: TColor32); {$IFDEF TEST_BLENDMEMRGB128SSE4} TBlendMemRGB128 = procedure(F: TColor32; var B: TColor32; W: UInt64); {$ENDIF} TBlendLine = procedure(Src, Dst: PColor32; Count: Integer); TBlendLineEx = procedure(Src, Dst: PColor32; Count: Integer; M: TColor32); TCombineReg = function(X, Y, W: TColor32): TColor32; TCombineMem = procedure(X: TColor32; var Y: TColor32; W: TColor32); TCombineLine = procedure(Src, Dst: PColor32; Count: Integer; W: TColor32); TLightenReg = function(C: TColor32; Amount: Integer): TColor32; var {$IFNDEF OMIT_MMX} EMMS: procedure; {$ENDIF} { Function Variables } BlendReg: TBlendReg; BlendMem: TBlendMem; BlendMems: TBlendMems; BlendRegEx: TBlendRegEx; BlendMemEx: TBlendMemEx; BlendRegRGB: TBlendRegRGB; BlendMemRGB: TBlendMemRGB; {$IFDEF TEST_BLENDMEMRGB128SSE4} BlendMemRGB128: TBlendMemRGB128; {$ENDIF} BlendLine: TBlendLine; BlendLineEx: TBlendLineEx; CombineReg: TCombineReg; CombineMem: TCombineMem; CombineLine: TCombineLine; MergeReg: TBlendReg; MergeMem: TBlendMem; MergeRegEx: TBlendRegEx; MergeMemEx: TBlendMemEx; MergeLine: TBlendLine; MergeLineEx: TBlendLineEx; { Color algebra functions } ColorAdd: TBlendReg; ColorSub: TBlendReg; ColorDiv: TBlendReg; ColorModulate: TBlendReg; ColorMax: TBlendReg; ColorMin: TBlendReg; ColorDifference: TBlendReg; ColorAverage: TBlendReg; ColorExclusion: TBlendReg; ColorScale: TBlendReg; { Special LUT pointers } AlphaTable: Pointer; bias_ptr: Pointer; alpha_ptr: Pointer; { Misc stuff } LightenReg: TLightenReg; function Lighten(C: TColor32; Amount: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} { Access to alpha composite functions corresponding to a combine mode } const BLEND_REG: array[TCombineMode] of ^TBlendReg = ((@@BlendReg),(@@MergeReg)); BLEND_MEM: array[TCombineMode] of ^TBlendMem = ((@@BlendMem),(@@MergeMem)); BLEND_REG_EX: array[TCombineMode] of ^TBlendRegEx = ((@@BlendRegEx),(@@MergeRegEx)); BLEND_MEM_EX: array[TCombineMode] of ^TBlendMemEx = ((@@BlendMemEx),(@@MergeMemEx)); BLEND_LINE: array[TCombineMode] of ^TBlendLine = ((@@BlendLine),(@@MergeLine)); BLEND_LINE_EX: array[TCombineMode] of ^TBlendLineEx = ((@@BlendLineEx),(@@MergeLineEx)); var BlendRegistry: TFunctionRegistry; {$IFDEF OMIT_MMX} procedure EMMS; {$IFDEF USEINLINING} inline; {$ENDIF} {$ENDIF} var RcTable: array [Byte, Byte] of Byte; DivTable: array [Byte, Byte] of Byte; implementation uses {$IFDEF TARGET_x86} GR32_LowLevel, {$ENDIF} GR32_System; {$IFDEF OMIT_MMX} procedure EMMS; begin end; {$ENDIF} { Pure Pascal } function BlendReg_Pas(F, B: TColor32): TColor32; var FX: TColor32Entry absolute F; BX: TColor32Entry absolute B; Af, Ab: PByteArray; FA : Byte; begin FA := FX.A; if FA = 0 then begin Result := B; Exit; end; if FA = $FF then begin Result := F; Exit; end; with BX do begin Af := @DivTable[FA]; Ab := @DivTable[not FA]; R := Af[FX.R] + Ab[R]; G := Af[FX.G] + Ab[G]; B := Af[FX.B] + Ab[B]; end; Result := B; end; procedure BlendMem_Pas(F: TColor32; var B: TColor32); var FX: TColor32Entry absolute F; BX: TColor32Entry absolute B; Af, Ab: PByteArray; FA : Byte; begin FA := FX.A; if FA = 0 then Exit; if FA = $FF then begin B := F; Exit; end; with BX do begin Af := @DivTable[FA]; Ab := @DivTable[not FA]; R := Af[FX.R] + Ab[R]; G := Af[FX.G] + Ab[G]; B := Af[FX.B] + Ab[B]; end; end; procedure BlendMems_Pas(F: TColor32; B: PColor32; Count: Integer); begin while Count > 0 do begin BlendMem(F, B^); Inc(B); Dec(Count); end; end; function BlendRegEx_Pas(F, B, M: TColor32): TColor32; var FX: TColor32Entry absolute F; BX: TColor32Entry absolute B; Af, Ab: PByteArray; begin Af := @DivTable[M]; M := Af[FX.A]; if M = 0 then begin Result := B; Exit; end; if M = $FF then begin Result := F; Exit; end; with BX do begin Af := @DivTable[M]; Ab := @DivTable[255 - M]; R := Af[FX.R] + Ab[R]; G := Af[FX.G] + Ab[G]; B := Af[FX.B] + Ab[B]; end; Result := B; end; procedure BlendMemEx_Pas(F: TColor32; var B: TColor32; M: TColor32); var FX: TColor32Entry absolute F; BX: TColor32Entry absolute B; Af, Ab: PByteArray; begin Af := @DivTable[M]; M := Af[FX.A]; if M = 0 then begin Exit; end; if M = $FF then begin B := F; Exit; end; with BX do begin Af := @DivTable[M]; Ab := @DivTable[255 - M]; R := Af[FX.R] + Ab[R]; G := Af[FX.G] + Ab[G]; B := Af[FX.B] + Ab[B]; end; end; function BlendRegRGB_Pas(F, B, W: TColor32): TColor32; var FX: TColor32Entry absolute F; BX: TColor32Entry absolute B; WX: TColor32Entry absolute W; RX: TColor32Entry absolute Result; begin RX.R := (FX.R - BX.R) * WX.B div 255 + BX.R; RX.G := (FX.G - BX.G) * WX.G div 255 + BX.G; RX.B := (FX.B - BX.B) * WX.R div 255 + BX.B; end; procedure BlendMemRGB_Pas(F: TColor32; var B: TColor32; W: TColor32); var FX: TColor32Entry absolute F; BX: TColor32Entry absolute B; WX: TColor32Entry absolute W; begin BX.R := (FX.R - BX.R) * WX.B div 255 + BX.R; BX.G := (FX.G - BX.G) * WX.G div 255 + BX.G; BX.B := (FX.B - BX.B) * WX.R div 255 + BX.B; end; procedure BlendLine_Pas(Src, Dst: PColor32; Count: Integer); begin while Count > 0 do begin BlendMem(Src^, Dst^); Inc(Src); Inc(Dst); Dec(Count); end; end; procedure BlendLineEx_Pas(Src, Dst: PColor32; Count: Integer; M: TColor32); begin while Count > 0 do begin BlendMemEx(Src^, Dst^, M); Inc(Src); Inc(Dst); Dec(Count); end; end; function CombineReg_Pas(X, Y, W: TColor32): TColor32; var Xe: TColor32Entry absolute X; Ye: TColor32Entry absolute Y; Af, Ab: PByteArray; begin if W = 0 then begin Result := Y; Exit; end; if W >= $FF then begin Result := X; Exit; end; with Xe do begin Af := @DivTable[W]; Ab := @DivTable[255 - W]; R := Ab[Ye.R] + Af[R]; G := Ab[Ye.G] + Af[G]; B := Ab[Ye.B] + Af[B]; end; Result := X; end; procedure CombineMem_Pas(X: TColor32; var Y: TColor32; W: TColor32); var Xe: TColor32Entry absolute X; Ye: TColor32Entry absolute Y; Af, Ab: PByteArray; begin if W = 0 then begin Exit; end; if W >= $FF then begin Y := X; Exit; end; with Xe do begin Af := @DivTable[W]; Ab := @DivTable[255 - W]; R := Ab[Ye.R] + Af[R]; G := Ab[Ye.G] + Af[G]; B := Ab[Ye.B] + Af[B]; end; Y := X; end; procedure CombineLine_Pas(Src, Dst: PColor32; Count: Integer; W: TColor32); begin while Count > 0 do begin CombineMem(Src^, Dst^, W); Inc(Src); Inc(Dst); Dec(Count); end; end; function MergeReg_Pas(F, B: TColor32): TColor32; var Fa, Ba, Wa: TColor32; Fw, Bw: PByteArray; Fx: TColor32Entry absolute F; Bx: TColor32Entry absolute B; Rx: TColor32Entry absolute Result; begin Fa := F shr 24; Ba := B shr 24; if Fa = $FF then Result := F else if Fa = $0 then Result := B else if Ba = $0 then Result := F else begin Rx.A := DivTable[Fa xor 255, Ba xor 255] xor 255; Wa := RcTable[Rx.A, Fa]; Fw := @DivTable[Wa]; Bw := @DivTable[Wa xor $FF]; Rx.R := Fw[Fx.R] + Bw[Bx.R]; Rx.G := Fw[Fx.G] + Bw[Bx.G]; Rx.B := Fw[Fx.B] + Bw[Bx.B]; end; end; function MergeRegEx_Pas(F, B, M: TColor32): TColor32; begin Result := MergeReg(DivTable[M, F shr 24] shl 24 or F and $00FFFFFF, B); end; procedure MergeMem_Pas(F: TColor32; var B: TColor32); begin B := MergeReg(F, B); end; procedure MergeMemEx_Pas(F: TColor32; var B: TColor32; M: TColor32); begin B := MergeReg(DivTable[M, F shr 24] shl 24 or F and $00FFFFFF, B); end; procedure MergeLine_Pas(Src, Dst: PColor32; Count: Integer); begin while Count > 0 do begin Dst^ := MergeReg(Src^, Dst^); Inc(Src); Inc(Dst); Dec(Count); end; end; procedure MergeLineEx_Pas(Src, Dst: PColor32; Count: Integer; M: TColor32); var PM: PByteArray absolute M; begin PM := @DivTable[M]; while Count > 0 do begin Dst^ := MergeReg((PM[Src^ shr 24] shl 24) or (Src^ and $00FFFFFF), Dst^); Inc(Src); Inc(Dst); Dec(Count); end; end; procedure EMMS_Pas; begin //Dummy end; function LightenReg_Pas(C: TColor32; Amount: Integer): TColor32; var r, g, b, a: Integer; CX: TColor32Entry absolute C; RX: TColor32Entry absolute Result; begin a := CX.A; r := CX.R; g := CX.G; b := CX.B; Inc(r, Amount); Inc(g, Amount); Inc(b, Amount); if r > 255 then r := 255 else if r < 0 then r := 0; if g > 255 then g := 255 else if g < 0 then g := 0; if b > 255 then b := 255 else if b < 0 then b := 0; RX.A := a; RX.R := r; RX.G := g; RX.B := b; end; { Color algebra } function ColorAdd_Pas(C1, C2: TColor32): TColor32; var r1, g1, b1, a1: Integer; r2, g2, b2, a2: Integer; begin a1 := C1 shr 24; r1 := C1 and $00FF0000; g1 := C1 and $0000FF00; b1 := C1 and $000000FF; a2 := C2 shr 24; r2 := C2 and $00FF0000; g2 := C2 and $0000FF00; b2 := C2 and $000000FF; a1 := a1 + a2; r1 := r1 + r2; g1 := g1 + g2; b1 := b1 + b2; if a1 > $FF then a1 := $FF; if r1 > $FF0000 then r1 := $FF0000; if g1 > $FF00 then g1 := $FF00; if b1 > $FF then b1 := $FF; Result := a1 shl 24 + r1 + g1 + b1; end; function ColorSub_Pas(C1, C2: TColor32): TColor32; var r1, g1, b1, a1: Integer; r2, g2, b2, a2: Integer; begin a1 := C1 shr 24; r1 := C1 and $00FF0000; g1 := C1 and $0000FF00; b1 := C1 and $000000FF; r1 := r1 shr 16; g1 := g1 shr 8; a2 := C2 shr 24; r2 := C2 and $00FF0000; g2 := C2 and $0000FF00; b2 := C2 and $000000FF; r2 := r2 shr 16; g2 := g2 shr 8; a1 := a1 - a2; r1 := r1 - r2; g1 := g1 - g2; b1 := b1 - b2; if a1 < 0 then a1 := 0; if r1 < 0 then r1 := 0; if g1 < 0 then g1 := 0; if b1 < 0 then b1 := 0; Result := a1 shl 24 + r1 shl 16 + g1 shl 8 + b1; end; function ColorDiv_Pas(C1, C2: TColor32): TColor32; var r1, g1, b1, a1: Integer; r2, g2, b2, a2: Integer; begin a1 := C1 shr 24; r1 := (C1 and $00FF0000) shr 16; g1 := (C1 and $0000FF00) shr 8; b1 := C1 and $000000FF; a2 := C2 shr 24; r2 := (C2 and $00FF0000) shr 16; g2 := (C2 and $0000FF00) shr 8; b2 := C2 and $000000FF; if a1 = 0 then a1:=$FF else a1 := (a2 shl 8) div a1; if r1 = 0 then r1:=$FF else r1 := (r2 shl 8) div r1; if g1 = 0 then g1:=$FF else g1 := (g2 shl 8) div g1; if b1 = 0 then b1:=$FF else b1 := (b2 shl 8) div b1; if a1 > $FF then a1 := $FF; if r1 > $FF then r1 := $FF; if g1 > $FF then g1 := $FF; if b1 > $FF then b1 := $FF; Result := a1 shl 24 + r1 shl 16 + g1 shl 8 + b1; end; function ColorModulate_Pas(C1, C2: TColor32): TColor32; var REnt: TColor32Entry absolute Result; C2Ent: TColor32Entry absolute C2; begin Result := C1; REnt.A := (C2Ent.A * REnt.A) shr 8; REnt.R := (C2Ent.R * REnt.R) shr 8; REnt.G := (C2Ent.G * REnt.G) shr 8; REnt.B := (C2Ent.B * REnt.B) shr 8; end; function ColorMax_Pas(C1, C2: TColor32): TColor32; var REnt: TColor32Entry absolute Result; C2Ent: TColor32Entry absolute C2; begin Result := C1; with C2Ent do begin if A > REnt.A then REnt.A := A; if R > REnt.R then REnt.R := R; if G > REnt.G then REnt.G := G; if B > REnt.B then REnt.B := B; end; end; function ColorMin_Pas(C1, C2: TColor32): TColor32; var REnt: TColor32Entry absolute Result; C2Ent: TColor32Entry absolute C2; begin Result := C1; with C2Ent do begin if A < REnt.A then REnt.A := A; if R < REnt.R then REnt.R := R; if G < REnt.G then REnt.G := G; if B < REnt.B then REnt.B := B; end; end; function ColorDifference_Pas(C1, C2: TColor32): TColor32; var r1, g1, b1, a1: TColor32; r2, g2, b2, a2: TColor32; begin a1 := C1 shr 24; r1 := C1 and $00FF0000; g1 := C1 and $0000FF00; b1 := C1 and $000000FF; r1 := r1 shr 16; g1 := g1 shr 8; a2 := C2 shr 24; r2 := C2 and $00FF0000; g2 := C2 and $0000FF00; b2 := C2 and $000000FF; r2 := r2 shr 16; g2 := g2 shr 8; a1 := abs(a2 - a1); r1 := abs(r2 - r1); g1 := abs(g2 - g1); b1 := abs(b2 - b1); Result := a1 shl 24 + r1 shl 16 + g1 shl 8 + b1; end; function ColorExclusion_Pas(C1, C2: TColor32): TColor32; var r1, g1, b1, a1: TColor32; r2, g2, b2, a2: TColor32; begin a1 := C1 shr 24; r1 := C1 and $00FF0000; g1 := C1 and $0000FF00; b1 := C1 and $000000FF; r1 := r1 shr 16; g1 := g1 shr 8; a2 := C2 shr 24; r2 := C2 and $00FF0000; g2 := C2 and $0000FF00; b2 := C2 and $000000FF; r2 := r2 shr 16; g2 := g2 shr 8; a1 := a1 + a2 - (a1 * a2 shr 7); r1 := r1 + r2 - (r1 * r2 shr 7); g1 := g1 + g2 - (g1 * g2 shr 7); b1 := b1 + b2 - (b1 * b2 shr 7); Result := a1 shl 24 + r1 shl 16 + g1 shl 8 + b1; end; function ColorAverage_Pas(C1, C2: TColor32): TColor32; //(A + B)/2 = (A and B) + (A xor B)/2 var C3 : TColor32; begin C3 := C1; C1 := C1 xor C2; C1 := C1 shr 1; C1 := C1 and $7F7F7F7F; C3 := C3 and C2; Result := C3 + C1; end; function ColorScale_Pas(C, W: TColor32): TColor32; var r1, g1, b1, a1: Cardinal; begin a1 := C shr 24; r1 := C and $00FF0000; g1 := C and $0000FF00; b1 := C and $000000FF; r1 := r1 shr 16; g1 := g1 shr 8; a1 := a1 * W shr 8; r1 := r1 * W shr 8; g1 := g1 * W shr 8; b1 := b1 * W shr 8; if a1 > 255 then a1 := 255; if r1 > 255 then r1 := 255; if g1 > 255 then g1 := 255; if b1 > 255 then b1 := 255; Result := a1 shl 24 + r1 shl 16 + g1 shl 8 + b1; end; {$IFNDEF PUREPASCAL} { Assembler versions } const bias = $00800080; function BlendReg_ASM(F, B: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // blend foreground color (F) to a background color (B), // using alpha channel value of F // Result Z = Fa * Frgb + (1 - Fa) * Brgb {$IFDEF TARGET_x86} // EAX <- F // EDX <- B // Test Fa = 255 ? CMP EAX,$FF000000 // Fa = 255 ? => Result = EAX JNC @2 // Test Fa = 0 ? TEST EAX,$FF000000 // Fa = 0 ? => Result = EDX JZ @1 // Get weight W = Fa * M MOV ECX,EAX // ECX <- Fa Fr Fg Fb SHR ECX,24 // ECX <- 00 00 00 Fa PUSH EBX // P = W * F MOV EBX,EAX // EBX <- Fa Fr Fg Fb AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND EBX,$FF00FF00 // EBX <- Fa 00 Fg 00 IMUL EAX,ECX // EAX <- Pr ** Pb ** SHR EBX,8 // EBX <- 00 Fa 00 Fg IMUL EBX,ECX // EBX <- Pa ** Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr ** Pb ADD EBX,bias AND EBX,$FF00FF00 // EBX <- Pa 00 Pg 00 OR EAX,EBX // EAX <- Pa Pr Pg Pb // W = 1 - W; Q = W * B XOR ECX,$000000FF // ECX <- 1 - ECX MOV EBX,EDX // EBX <- Ba Br Bg Bb AND EDX,$00FF00FF // EDX <- 00 Br 00 Bb AND EBX,$FF00FF00 // EBX <- Ba 00 Bg 00 IMUL EDX,ECX // EDX <- Qr ** Qb ** SHR EBX,8 // EBX <- 00 Ba 00 Bg IMUL EBX,ECX // EBX <- Qa ** Qg ** ADD EDX,bias AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 00 SHR EDX,8 // EDX <- 00 Qr ** Qb ADD EBX,bias AND EBX,$FF00FF00 // EBX <- Qa 00 Qg 00 OR EBX,EDX // EBX <- Qa Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,EBX // EAX <- Za Zr Zg Zb POP EBX RET @1: MOV EAX,EDX @2: {$ENDIF} // EAX <- F // EDX <- B {$IFDEF TARGET_x64} MOV RAX, RCX // Test Fa = 255 ? CMP EAX,$FF000000 // Fa = 255 ? => Result = EAX JNC @2 // Test Fa = 0 ? TEST EAX,$FF000000 // Fa = 0 ? => Result = EDX JZ @1 // Get weight W = Fa * M MOV ECX,EAX // ECX <- Fa Fr Fg Fb SHR ECX,24 // ECX <- 00 00 00 Fa // P = W * F MOV R9D,EAX // R9D <- Fa Fr Fg Fb AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND R9D,$FF00FF00 // R9D <- Fa 00 Fg 00 IMUL EAX,ECX // EAX <- Pr ** Pb ** SHR R9D,8 // R9D <- 00 Fa 00 Fg IMUL R9D,ECX // R9D <- Pa ** Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr ** Pb ADD R9D,bias AND R9D,$FF00FF00 // R9D <- Pa 00 Pg 00 OR EAX,R9D // EAX <- Pa Pr Pg Pb // W = 1 - W; Q = W * B XOR ECX,$000000FF // ECX <- 1 - ECX MOV R9D,EDX // R9D <- Ba Br Bg Bb AND EDX,$00FF00FF // EDX <- 00 Br 00 Bb AND R9D,$FF00FF00 // R9D <- Ba 00 Bg 00 IMUL EDX,ECX // EDX <- Qr ** Qb ** SHR R9D,8 // R9D <- 00 Ba 00 Bg IMUL R9D,ECX // R9D <- Qa ** Qg ** ADD EDX,bias AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 00 SHR EDX,8 // EDX <- 00 Qr ** Qb ADD R9D,bias AND R9D,$FF00FF00 // R9D <- Qa 00 Qg 00 OR R9D,EDX // R9D <- Qa Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,R9D // EAX <- Za Zr Zg Zb RET @1: MOV EAX,EDX @2: {$ENDIF} end; procedure BlendMem_ASM(F: TColor32; var B: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX <- F // [EDX] <- B // Test Fa = 0 ? TEST EAX,$FF000000 // Fa = 0 ? => do not write JZ @2 // Get weight W = Fa * M MOV ECX,EAX // ECX <- Fa Fr Fg Fb SHR ECX,24 // ECX <- 00 00 00 Fa // Test Fa = 255 ? CMP ECX,$FF JZ @1 PUSH EBX PUSH ESI // P = W * F MOV EBX,EAX // EBX <- Fa Fr Fg Fb AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND EBX,$FF00FF00 // EBX <- Fa 00 Fg 00 IMUL EAX,ECX // EAX <- Pr ** Pb ** SHR EBX,8 // EBX <- 00 Fa 00 Fg IMUL EBX,ECX // EBX <- Pa ** Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr ** Pb ADD EBX,bias AND EBX,$FF00FF00 // EBX <- Pa 00 Pg 00 OR EAX,EBX // EAX <- Pa Pr Pg Pb MOV ESI,[EDX] // W = 1 - W; Q = W * B XOR ECX,$000000FF // ECX <- 1 - ECX MOV EBX,ESI // EBX <- Ba Br Bg Bb AND ESI,$00FF00FF // ESI <- 00 Br 00 Bb AND EBX,$FF00FF00 // EBX <- Ba 00 Bg 00 IMUL ESI,ECX // ESI <- Qr ** Qb ** SHR EBX,8 // EBX <- 00 Ba 00 Bg IMUL EBX,ECX // EBX <- Qa ** Qg ** ADD ESI,bias AND ESI,$FF00FF00 // ESI <- Qr 00 Qb 00 SHR ESI,8 // ESI <- 00 Qr ** Qb ADD EBX,bias AND EBX,$FF00FF00 // EBX <- Qa 00 Qg 00 OR EBX,ESI // EBX <- Qa Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,EBX // EAX <- Za Zr Zg Zb MOV [EDX],EAX POP ESI POP EBX RET @1: MOV [EDX],EAX @2: {$ENDIF} {$IFDEF TARGET_x64} // ECX <- F // [RDX] <- B // Test Fa = 0 ? TEST ECX,$FF000000 // Fa = 0 ? => do not write JZ @2 MOV EAX, ECX // EAX <- Fa Fr Fg Fb // Get weight W = Fa * M SHR ECX,24 // ECX <- 00 00 00 Fa // Test Fa = 255 ? CMP ECX,$FF JZ @1 // P = W * F MOV R8D,EAX // R8D <- Fa Fr Fg Fb AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND R8D,$FF00FF00 // R8D <- Fa 00 Fg 00 IMUL EAX,ECX // EAX <- Pr ** Pb ** SHR R8D,8 // R8D <- 00 Fa 00 Fg IMUL R8D,ECX // R8D <- Pa ** Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr ** Pb ADD R8D,bias AND R8D,$FF00FF00 // R8D <- Pa 00 Pg 00 OR EAX,R8D // EAX <- Pa Pr Pg Pb MOV R9D,[RDX] // W = 1 - W; Q = W * B XOR ECX,$000000FF // ECX <- 1 - ECX MOV R8D,R9D // R8D <- Ba Br Bg Bb AND R9D,$00FF00FF // R9D <- 00 Br 00 Bb AND R8D,$FF00FF00 // R8D <- Ba 00 Bg 00 IMUL R9D,ECX // R9D <- Qr ** Qb ** SHR R8D,8 // R8D <- 00 Ba 00 Bg IMUL R8D,ECX // R8D <- Qa ** Qg ** ADD R9D,bias AND R9D,$FF00FF00 // R9D <- Qr 00 Qb 00 SHR R9D,8 // R9D <- 00 Qr ** Qb ADD R8D,bias AND R8D,$FF00FF00 // R8D <- Qa 00 Qg 00 OR R8D,R9D // R8D <- Qa Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,R8D // EAX <- Za Zr Zg Zb MOV [RDX],EAX RET @1: MOV [RDX],EAX @2: {$ENDIF} end; procedure BlendMems_ASM(F: TColor32; B: PColor32; Count: Integer); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} TEST ECX,ECX JZ @Done PUSH EBX PUSH ESI PUSH EDI MOV ESI,EAX MOV EDI,EDX @LoopStart: MOV EAX,[ESI] TEST EAX,$FF000000 JZ @NextPixel PUSH ECX MOV ECX,EAX SHR ECX,24 CMP ECX,$FF JZ @CopyPixel MOV EBX,EAX AND EAX,$00FF00FF AND EBX,$FF00FF00 IMUL EAX,ECX SHR EBX,8 IMUL EBX,ECX ADD EAX,bias AND EAX,$FF00FF00 SHR EAX,8 ADD EBX,bias AND EBX,$FF00FF00 OR EAX,EBX MOV EDX,[EDI] XOR ECX,$000000FF MOV EBX,EDX AND EDX,$00FF00FF AND EBX,$FF00FF00 IMUL EDX,ECX SHR EBX,8 IMUL EBX,ECX ADD EDX,bias AND EDX,$FF00FF00 SHR EDX,8 ADD EBX,bias AND EBX,$FF00FF00 OR EBX,EDX ADD EAX,EBX @CopyPixel: OR EAX,$FF000000 MOV [EDI],EAX POP ECX @NextPixel: ADD ESI,4 ADD EDI,4 DEC ECX JNZ @LoopStart POP EDI POP ESI POP EBX @Done: RET {$ENDIF} {$IFDEF TARGET_x64} TEST R8D,R8D JZ @Done PUSH RDI MOV R9,RCX MOV RDI,RDX @LoopStart: MOV ECX,[RSI] TEST ECX,$FF000000 JZ @NextPixel PUSH R8 MOV R8D,ECX SHR R8D,24 CMP R8D,$FF JZ @CopyPixel MOV EAX,ECX AND ECX,$00FF00FF AND EAX,$FF00FF00 IMUL ECX,R8D SHR EAX,8 IMUL EAX,R8D ADD ECX,bias AND ECX,$FF00FF00 SHR ECX,8 ADD EAX,bias AND EAX,$FF00FF00 OR ECX,EAX MOV EDX,[RDI] XOR R8D,$000000FF MOV EAX,EDX AND EDX,$00FF00FF AND EAX,$FF00FF00 IMUL EDX, R8D SHR EAX,8 IMUL EAX,R8D ADD EDX,bias AND EDX,$FF00FF00 SHR EDX,8 ADD EAX,bias AND EAX,$FF00FF00 OR EAX,EDX ADD ECX,EAX @CopyPixel: OR ECX,$FF000000 MOV [RDI],ECX POP R8 @NextPixel: ADD R9,4 ADD RDI,4 DEC R8D JNZ @LoopStart POP RDI @Done: RET {$ENDIF} end; function BlendRegEx_ASM(F, B, M: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // blend foreground color (F) to a background color (B), // using alpha channel value of F multiplied by master alpha (M) // no checking for M = $FF, in this case Graphics32 uses BlendReg // Result Z = Fa * M * Frgb + (1 - Fa * M) * Brgb // EAX <- F // EDX <- B // ECX <- M {$IFDEF TARGET_x86} // Check Fa > 0 ? TEST EAX,$FF000000 // Fa = 0? => Result := EDX JZ @2 PUSH EBX // Get weight W = Fa * M MOV EBX,EAX // EBX <- Fa Fr Fg Fb INC ECX // 255:256 range bias SHR EBX,24 // EBX <- 00 00 00 Fa IMUL ECX,EBX // ECX <- 00 00 W ** SHR ECX,8 // ECX <- 00 00 00 W JZ @1 // W = 0 ? => Result := EDX // P = W * F MOV EBX,EAX // EBX <- ** Fr Fg Fb AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND EBX,$0000FF00 // EBX <- 00 00 Fg 00 IMUL EAX,ECX // EAX <- Pr ** Pb ** SHR EBX,8 // EBX <- 00 00 00 Fg IMUL EBX,ECX // EBX <- 00 00 Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr ** Pb ADD EBX,bias AND EBX,$0000FF00 // EBX <- 00 00 Pg 00 OR EAX,EBX // EAX <- 00 Pr Pg Pb // W = 1 - W; Q = W * B XOR ECX,$000000FF // ECX <- 1 - ECX MOV EBX,EDX // EBX <- 00 Br Bg Bb AND EDX,$00FF00FF // EDX <- 00 Br 00 Bb AND EBX,$0000FF00 // EBX <- 00 00 Bg 00 IMUL EDX,ECX // EDX <- Qr ** Qb ** SHR EBX,8 // EBX <- 00 00 00 Bg IMUL EBX,ECX // EBX <- 00 00 Qg ** ADD EDX,bias AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 00 SHR EDX,8 // EDX <- 00 Qr ** Qb ADD EBX,bias AND EBX,$0000FF00 // EBX <- 00 00 Qg 00 OR EBX,EDX // EBX <- 00 Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,EBX // EAX <- 00 Zr Zg Zb POP EBX RET @1: POP EBX @2: MOV EAX,EDX {$ENDIF} {$IFDEF TARGET_x64} MOV EAX,ECX // EAX <- Fa Fr Fg Fb TEST EAX,$FF000000 // Fa = 0? => Result := EDX JZ @1 // Get weight W = Fa * M INC R8D // 255:256 range bias SHR ECX,24 // ECX <- 00 00 00 Fa IMUL R8D,ECX // R8D <- 00 00 W ** SHR R8D,8 // R8D <- 00 00 00 W JZ @1 // W = 0 ? => Result := EDX // P = W * F MOV ECX,EAX // ECX <- ** Fr Fg Fb AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND ECX,$0000FF00 // ECX <- 00 00 Fg 00 IMUL EAX,R8D // EAX <- Pr ** Pb ** SHR ECX,8 // ECX <- 00 00 00 Fg IMUL ECX,R8D // ECX <- 00 00 Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr ** Pb ADD ECX,bias AND ECX,$0000FF00 // ECX <- 00 00 Pg 00 OR EAX,ECX // EAX <- 00 Pr Pg Pb // W = 1 - W; Q = W * B XOR R8D,$000000FF // R8D <- 1 - R8D MOV ECX,EDX // ECX <- 00 Br Bg Bb AND EDX,$00FF00FF // EDX <- 00 Br 00 Bb AND ECX,$0000FF00 // ECX <- 00 00 Bg 00 IMUL EDX,R8D // EDX <- Qr ** Qb ** SHR ECX,8 // ECX <- 00 00 00 Bg IMUL ECX,R8D // ECX <- 00 00 Qg ** ADD EDX,bias AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 00 SHR EDX,8 // EDX <- 00 Qr ** Qb ADD ECX,bias AND ECX,$0000FF00 // ECX <- 00 00 Qg 00 OR ECX,EDX // ECX <- 00 Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,ECX // EAX <- 00 Zr Zg Zb RET @1: MOV EAX,EDX {$ENDIF} end; procedure BlendMemEx_ASM(F: TColor32; var B: TColor32; M: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX <- F // [EDX] <- B // ECX <- M // Check Fa > 0 ? TEST EAX,$FF000000 // Fa = 0? => write nothing JZ @2 PUSH EBX // Get weight W = Fa * M MOV EBX,EAX // EBX <- Fa Fr Fg Fb INC ECX // 255:256 range bias SHR EBX,24 // EBX <- 00 00 00 Fa IMUL ECX,EBX // ECX <- 00 00 W ** SHR ECX,8 // ECX <- 00 00 00 W JZ @1 // W = 0 ? => write nothing PUSH ESI // P = W * F MOV EBX,EAX // EBX <- ** Fr Fg Fb AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND EBX,$0000FF00 // EBX <- 00 00 Fg 00 IMUL EAX,ECX // EAX <- Pr ** Pb ** SHR EBX,8 // EBX <- 00 00 00 Fg IMUL EBX,ECX // EBX <- 00 00 Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr ** Pb ADD EBX,bias AND EBX,$0000FF00 // EBX <- 00 00 Pg 00 OR EAX,EBX // EAX <- 00 Pr Pg Pb // W = 1 - W; Q = W * B MOV ESI,[EDX] XOR ECX,$000000FF // ECX <- 1 - ECX MOV EBX,ESI // EBX <- 00 Br Bg Bb AND ESI,$00FF00FF // ESI <- 00 Br 00 Bb AND EBX,$0000FF00 // EBX <- 00 00 Bg 00 IMUL ESI,ECX // ESI <- Qr ** Qb ** SHR EBX,8 // EBX <- 00 00 00 Bg IMUL EBX,ECX // EBX <- 00 00 Qg ** ADD ESI,bias AND ESI,$FF00FF00 // ESI <- Qr 00 Qb 00 SHR ESI,8 // ESI <- 00 Qr ** Qb ADD EBX,bias AND EBX,$0000FF00 // EBX <- 00 00 Qg 00 OR EBX,ESI // EBX <- 00 Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,EBX // EAX <- 00 Zr Zg Zb MOV [EDX],EAX POP ESI @1: POP EBX @2: {$ENDIF} {$IFDEF TARGET_x64} // ECX <- F // [RDX] <- B // R8 <- M // ECX <- F // [EDX] <- B // R8 <- M // Check Fa > 0 ? TEST ECX,$FF000000 // Fa = 0? => write nothing JZ @1 // Get weight W = Fa * M MOV EAX,ECX // EAX <- Fa Fr Fg Fb INC R8D // 255:256 range bias SHR EAX,24 // EAX <- 00 00 00 Fa IMUL R8D,EAX // R8D <- 00 00 W ** SHR R8D,8 // R8D <- 00 00 00 W JZ @1 // W = 0 ? => write nothing // P = W * F MOV EAX,ECX // EAX <- ** Fr Fg Fb AND ECX,$00FF00FF // ECX <- 00 Fr 00 Fb AND EAX,$0000FF00 // EAX <- 00 00 Fg 00 IMUL ECX,R8D // ECX <- Pr ** Pb ** SHR EAX,8 // EAX <- 00 00 00 Fg IMUL EAX,R8D // EAX <- 00 00 Pg ** ADD ECX,bias AND ECX,$FF00FF00 // ECX <- Pr 00 Pb 00 SHR ECX,8 // ECX <- 00 Pr ** Pb ADD EAX,bias AND EAX,$0000FF00 // EAX <- 00 00 Pg 00 OR ECX,EAX // ECX <- 00 Pr Pg Pb // W = 1 - W; Q = W * B MOV R9D,[RDX] XOR R8D,$000000FF // R8D <- 1 - R8 MOV EAX,R9D // EAX <- 00 Br Bg Bb AND R9D,$00FF00FF // R9D <- 00 Br 00 Bb AND EAX,$0000FF00 // EAX <- 00 00 Bg 00 IMUL R9D,R8D // R9D <- Qr ** Qb ** SHR EAX,8 // EAX <- 00 00 00 Bg IMUL EAX,R8D // EAX <- 00 00 Qg ** ADD R9D,bias AND R9D,$FF00FF00 // R9D <- Qr 00 Qb 00 SHR R9D,8 // R9D <- 00 Qr ** Qb ADD EAX,bias AND EAX,$0000FF00 // EAX <- 00 00 Qg 00 OR EAX,R9D // EAX <- 00 Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD ECX,EAX // ECX <- 00 Zr Zg Zb MOV [RDX],ECX @1: {$ENDIF} end; procedure BlendLine_ASM(Src, Dst: PColor32; Count: Integer); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX <- Src // EDX <- Dst // ECX <- Count // test the counter for zero or negativity TEST ECX,ECX JS @4 PUSH EBX PUSH ESI PUSH EDI MOV ESI,EAX // ESI <- Src MOV EDI,EDX // EDI <- Dst // loop start @1: MOV EAX,[ESI] TEST EAX,$FF000000 JZ @3 // complete transparency, proceed to next point PUSH ECX // store counter // Get weight W = Fa * M MOV ECX,EAX // ECX <- Fa Fr Fg Fb SHR ECX,24 // ECX <- 00 00 00 Fa // Test Fa = 255 ? CMP ECX,$FF JZ @2 // P = W * F MOV EBX,EAX // EBX <- Fa Fr Fg Fb AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND EBX,$FF00FF00 // EBX <- Fa 00 Fg 00 IMUL EAX,ECX // EAX <- Pr ** Pb ** SHR EBX,8 // EBX <- 00 Fa 00 Fg IMUL EBX,ECX // EBX <- Pa ** Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr ** Pb ADD EBX,bias AND EBX,$FF00FF00 // EBX <- Pa 00 Pg 00 OR EAX,EBX // EAX <- Pa Pr Pg Pb // W = 1 - W; Q = W * B MOV EDX,[EDI] XOR ECX,$000000FF // ECX <- 1 - ECX MOV EBX,EDX // EBX <- Ba Br Bg Bb AND EDX,$00FF00FF // ESI <- 00 Br 00 Bb AND EBX,$FF00FF00 // EBX <- Ba 00 Bg 00 IMUL EDX,ECX // ESI <- Qr ** Qb ** SHR EBX,8 // EBX <- 00 Ba 00 Bg IMUL EBX,ECX // EBX <- Qa ** Qg ** ADD EDX,bias AND EDX,$FF00FF00 // ESI <- Qr 00 Qb 00 SHR EDX,8 // ESI <- 00 Qr ** Qb ADD EBX,bias AND EBX,$FF00FF00 // EBX <- Qa 00 Qg 00 OR EBX,EDX // EBX <- Qa Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,EBX // EAX <- Za Zr Zg Zb @2: MOV [EDI],EAX POP ECX // restore counter @3: ADD ESI,4 ADD EDI,4 // loop end DEC ECX JNZ @1 POP EDI POP ESI POP EBX @4: {$ENDIF} {$IFDEF TARGET_x64} // RCX <- Src // RDX <- Dst // R8 <- Count // test the counter for zero or negativity TEST R8D,R8D JS @4 MOV R10,RCX // R10 <- Src MOV R11,RDX // R11 <- Dst MOV ECX,R8D // RCX <- Count // loop start @1: MOV EAX,[R10] TEST EAX,$FF000000 JZ @3 // complete transparency, proceed to next point // Get weight W = Fa * M MOV R9D,EAX // R9D <- Fa Fr Fg Fb SHR R9D,24 // R9D <- 00 00 00 Fa // Test Fa = 255 ? CMP R9D,$FF JZ @2 // P = W * F MOV R8D,EAX // R8D <- Fa Fr Fg Fb AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND R8D,$FF00FF00 // R8D <- Fa 00 Fg 00 IMUL EAX,R9D // EAX <- Pr ** Pb ** SHR R8D,8 // R8D <- 00 Fa 00 Fg IMUL R8D,R9D // R8D <- Pa ** Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr ** Pb ADD R8D,bias AND R8D,$FF00FF00 // R8D <- Pa 00 Pg 00 OR EAX,R8D // EAX <- Pa Pr Pg Pb // W = 1 - W; Q = W * B MOV EDX,[R11] XOR R9D,$000000FF // R9D <- 1 - R9D MOV R8D,EDX // R8D <- Ba Br Bg Bb AND EDX,$00FF00FF // ESI <- 00 Br 00 Bb AND R8D,$FF00FF00 // R8D <- Ba 00 Bg 00 IMUL EDX,R9D // ESI <- Qr ** Qb ** SHR R8D,8 // R8D <- 00 Ba 00 Bg IMUL R8D,R9D // R8D <- Qa ** Qg ** ADD EDX,bias AND EDX,$FF00FF00 // ESI <- Qr 00 Qb 00 SHR EDX,8 // ESI <- 00 Qr ** Qb ADD R8D,bias AND R8D,$FF00FF00 // R8D <- Qa 00 Qg 00 OR R8D,EDX // R8D <- Qa Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,R8D // EAX <- Za Zr Zg Zb @2: MOV [R11],EAX @3: ADD R10,4 ADD R11,4 // loop end DEC ECX JNZ @1 @4: {$ENDIF} end; {$IFDEF TARGET_x86} function MergeReg_ASM(F, B: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // EAX <- F // EDX <- B // if F.A = 0 then TEST EAX,$FF000000 JZ @exit0 // else if B.A = 255 then CMP EDX,$FF000000 JNC @blend // else if F.A = 255 then CMP EAX,$FF000000 JNC @Exit // else if B.A = 0 then TEST EDX,$FF000000 JZ @Exit @4: PUSH EBX PUSH ESI PUSH EDI ADD ESP,-$0C MOV [ESP+$04],EDX MOV [ESP],EAX // AH <- F.A // DL, CL <- B.A SHR EAX,16 AND EAX,$0000FF00 SHR EDX,24 MOV CL,DL NOP NOP NOP // EDI <- PF // EDX <- PB // ESI <- PR // PF := @DivTable[F.A]; LEA EDI,[EAX+DivTable] // PB := @DivTable[B.A]; SHL EDX,$08 LEA EDX,[EDX+DivTable] // Result.A := B.A + F.A - PB[F.A]; SHR EAX,8 //ADD CL,AL ADD ECX,EAX //SUB CL,[EDX+EAX] SUB ECX,[EDX+EAX] MOV [ESP+$0B],CL // PR := @RcTable[Result.A]; SHL ECX,$08 AND ECX,$0000FFFF LEA ESI,[ECX+RcTable] { Red component } // Result.R := PB[B.R]; XOR EAX,EAX MOV AL,[ESP+$06] MOV CL,[EDX+EAX] MOV [ESP+$0a],CL // X := F.R - Result.R; MOV AL,[ESP+$02] XOR EBX,EBX MOV BL,CL SUB EAX,EBX // if X >= 0 then JL @5 // Result.R := PR[PF[X] + Result.R] MOVZX EAX,BYTE PTR[EDI+EAX] AND ECX,$000000FF ADD EAX,ECX MOV AL,[ESI+EAX] MOV [ESP+$0A],AL JMP @6 @5: // Result.R := PR[Result.R - PF[-X]]; NEG EAX MOVZX EAX,BYTE PTR[EDI+EAX] XOR ECX,ECX MOV CL,[ESP+$0A] SUB ECX,EAX MOV AL,[ESI+ECX] MOV [ESP+$0A],AL { Green component } @6: // Result.G := PB[B.G]; XOR EAX,EAX MOV AL,[ESP+$05] MOV CL,[EDX+EAX] MOV [ESP+$09],CL // X := F.G - Result.G; MOV AL,[ESP+$01] XOR EBX,EBX MOV BL,CL SUB EAX,EBX // if X >= 0 then JL @7 // Result.G := PR[PF[X] + Result.G] MOVZX EAX,BYTE PTR[EDI+EAX] AND ECX,$000000FF ADD EAX,ECX MOV AL,[ESI+EAX] MOV [ESP+$09],AL JMP @8 @7: // Result.G := PR[Result.G - PF[-X]]; NEG EAX MOVZX EAX,BYTE PTR[EDI+EAX] XOR ECX,ECX MOV CL,[ESP+$09] SUB ECX,EAX MOV AL,[ESI+ECX] MOV [ESP+$09],AL { Blue component } @8: // Result.B := PB[B.B]; XOR EAX,EAX MOV AL,[ESP+$04] MOV CL,[EDX+EAX] MOV [ESP+$08],CL // X := F.B - Result.B; MOV AL,[ESP] XOR EDX,EDX MOV DL,CL SUB EAX,EDX // if X >= 0 then JL @9 // Result.B := PR[PF[X] + Result.B] MOVZX EAX,BYTE PTR[EDI+EAX] XOR EDX,EDX MOV DL,CL ADD EAX,EDX MOV AL,[ESI+EAX] MOV [ESP+$08],AL JMP @10 @9: // Result.B := PR[Result.B - PF[-X]]; NEG EAX MOVZX EAX,BYTE PTR[EDI+EAX] XOR EDX,EDX MOV DL,CL SUB EDX,EAX MOV AL,[ESI+EDX] MOV [ESP+$08],AL @10: // EAX <- Result MOV EAX,[ESP+$08] // end; ADD ESP,$0C POP EDI POP ESI POP EBX RET @blend: CALL DWORD PTR [BlendReg] OR EAX,$FF000000 RET @exit0: MOV EAX,EDX @Exit: end; {$ENDIF} function CombineReg_ASM(X, Y, W: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // combine RGBA channels of colors X and Y with the weight of X given in W // Result Z = W * X + (1 - W) * Y (all channels are combined, including alpha) {$IFDEF TARGET_x86} // EAX <- X // EDX <- Y // ECX <- W // W = 0 or $FF? JCXZ @1 // CX = 0 ? => Result := EDX CMP ECX,$FF // CX = $FF ? => Result := EDX JE @2 PUSH EBX // P = W * X MOV EBX,EAX // EBX <- Xa Xr Xg Xb AND EAX,$00FF00FF // EAX <- 00 Xr 00 Xb AND EBX,$FF00FF00 // EBX <- Xa 00 Xg 00 IMUL EAX,ECX // EAX <- Pr ** Pb ** SHR EBX,8 // EBX <- 00 Xa 00 Xg IMUL EBX,ECX // EBX <- Pa ** Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pa 00 Pg 00 SHR EAX,8 // EAX <- 00 Pr 00 Pb ADD EBX,bias AND EBX,$FF00FF00 // EBX <- Pa 00 Pg 00 OR EAX,EBX // EAX <- Pa Pr Pg Pb // W = 1 - W; Q = W * Y XOR ECX,$000000FF // ECX <- 1 - ECX MOV EBX,EDX // EBX <- Ya Yr Yg Yb AND EDX,$00FF00FF // EDX <- 00 Yr 00 Yb AND EBX,$FF00FF00 // EBX <- Ya 00 Yg 00 IMUL EDX,ECX // EDX <- Qr ** Qb ** SHR EBX,8 // EBX <- 00 Ya 00 Yg IMUL EBX,ECX // EBX <- Qa ** Qg ** ADD EDX,bias AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 00 SHR EDX,8 // EDX <- 00 Qr ** Qb ADD EBX,bias AND EBX,$FF00FF00 // EBX <- Qa 00 Qg 00 OR EBX,EDX // EBX <- Qa Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,EBX // EAX <- Za Zr Zg Zb POP EBX RET @1: MOV EAX,EDX @2: {$ENDIF} {$IFDEF TARGET_x64} // ECX <- X // EDX <- Y // R8D <- W // W = 0 or $FF? TEST R8D,R8D JZ @1 // W = 0 ? => Result := EDX MOV EAX,ECX // EAX <- Xa Xr Xg Xb CMP R8B,$FF // W = $FF ? => Result := EDX JE @2 // P = W * X AND EAX,$00FF00FF // EAX <- 00 Xr 00 Xb AND ECX,$FF00FF00 // ECX <- Xa 00 Xg 00 IMUL EAX,R8D // EAX <- Pr ** Pb ** SHR ECX,8 // ECX <- 00 Xa 00 Xg IMUL ECX,R8D // ECX <- Pa ** Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pa 00 Pg 00 SHR EAX,8 // EAX <- 00 Pr 00 Pb ADD ECX,bias AND ECX,$FF00FF00 // ECX <- Pa 00 Pg 00 OR EAX,ECX // EAX <- Pa Pr Pg Pb // W = 1 - W; Q = W * Y XOR R8D,$000000FF // R8D <- 1 - R8D MOV ECX,EDX // ECX <- Ya Yr Yg Yb AND EDX,$00FF00FF // EDX <- 00 Yr 00 Yb AND ECX,$FF00FF00 // ECX <- Ya 00 Yg 00 IMUL EDX,R8D // EDX <- Qr ** Qb ** SHR ECX,8 // ECX <- 00 Ya 00 Yg IMUL ECX,R8D // ECX <- Qa ** Qg ** ADD EDX,bias AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 00 SHR EDX,8 // EDX <- 00 Qr ** Qb ADD ECX,bias AND ECX,$FF00FF00 // ECX <- Qa 00 Qg 00 OR ECX,EDX // ECX <- Qa Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,ECX // EAX <- Za Zr Zg Zb RET @1: MOV EAX,EDX @2: {$ENDIF} end; procedure CombineMem_ASM(X: TColor32; var Y: TColor32; W: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX <- F // [EDX] <- B // ECX <- W // Check W JCXZ @1 // W = 0 ? => write nothing CMP ECX,$FF // W = 255? => write F {$IFDEF FPC} DB $74,$76 //Prob with FPC 2.2.2 and below {$ELSE} JZ @2 {$ENDIF} PUSH EBX PUSH ESI // P = W * F MOV EBX,EAX // EBX <- ** Fr Fg Fb AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND EBX,$FF00FF00 // EBX <- Fa 00 Fg 00 IMUL EAX,ECX // EAX <- Pr ** Pb ** SHR EBX,8 // EBX <- 00 Fa 00 Fg IMUL EBX,ECX // EBX <- 00 00 Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr 00 Pb ADD EBX,bias AND EBX,$FF00FF00 // EBX <- Pa 00 Pg 00 OR EAX,EBX // EAX <- 00 Pr Pg Pb // W = 1 - W; Q = W * B MOV ESI,[EDX] XOR ECX,$000000FF // ECX <- 1 - ECX MOV EBX,ESI // EBX <- Ba Br Bg Bb AND ESI,$00FF00FF // ESI <- 00 Br 00 Bb AND EBX,$FF00FF00 // EBX <- Ba 00 Bg 00 IMUL ESI,ECX // ESI <- Qr ** Qb ** SHR EBX,8 // EBX <- 00 Ba 00 Bg IMUL EBX,ECX // EBX <- Qa 00 Qg ** ADD ESI,bias AND ESI,$FF00FF00 // ESI <- Qr 00 Qb 00 SHR ESI,8 // ESI <- 00 Qr ** Qb ADD EBX,bias AND EBX,$FF00FF00 // EBX <- Qa 00 Qg 00 OR EBX,ESI // EBX <- 00 Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,EBX // EAX <- 00 Zr Zg Zb MOV [EDX],EAX POP ESI POP EBX @1: RET @2: MOV [EDX],EAX {$ENDIF} {$IFDEF TARGET_x64} // ECX <- F // [RDX] <- B // R8 <- W // Check W TEST R8D,R8D // Set flags for R8 JZ @2 // W = 0 ? => Result := EDX MOV EAX,ECX // EAX <- ** Fr Fg Fb CMP R8B,$FF // W = 255? => write F JZ @1 // P = W * F AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb AND ECX,$FF00FF00 // ECX <- Fa 00 Fg 00 IMUL EAX,R8D // EAX <- Pr ** Pb ** SHR ECX,8 // ECX <- 00 Fa 00 Fg IMUL ECX,R8D // ECX <- 00 00 Pg ** ADD EAX,bias AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00 SHR EAX,8 // EAX <- 00 Pr 00 Pb ADD ECX,bias AND ECX,$FF00FF00 // ECX <- Pa 00 Pg 00 OR EAX,ECX // EAX <- 00 Pr Pg Pb // W = 1 - W; Q = W * B MOV R9D,[RDX] XOR R8D,$000000FF // R8D <- 1 - R8D MOV ECX,R9D // ECX <- Ba Br Bg Bb AND R9D,$00FF00FF // R9D <- 00 Br 00 Bb AND ECX,$FF00FF00 // ECX <- Ba 00 Bg 00 IMUL R9D,R8D // R9D <- Qr ** Qb ** SHR ECX,8 // ECX <- 00 Ba 00 Bg IMUL ECX,R8D // ECX <- Qa 00 Qg ** ADD R9D,bias AND R9D,$FF00FF00 // R9D <- Qr 00 Qb 00 SHR R9D,8 // R9D <- 00 Qr ** Qb ADD ECX,bias AND ECX,$FF00FF00 // ECX <- Qa 00 Qg 00 OR ECX,R9D // ECX <- 00 Qr Qg Qb // Z = P + Q (assuming no overflow at each byte) ADD EAX,ECX // EAX <- 00 Zr Zg Zb @1: MOV [RDX],EAX @2: {$ENDIF} end; procedure EMMS_ASM; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm end; procedure GenAlphaTable; var I: Integer; L: LongWord; P: PLongWord; begin GetMem(AlphaTable, 257 * 8 * SizeOf(Cardinal)); {$IFDEF HAS_NATIVEINT} alpha_ptr := Pointer(NativeUInt(AlphaTable) and (not $F)); if NativeUInt(alpha_ptr) < NativeUInt(AlphaTable) then alpha_ptr := Pointer(NativeUInt(alpha_ptr) + 16); {$ELSE} alpha_ptr := Pointer(Cardinal(AlphaTable) and (not $F)); if Cardinal(alpha_ptr) < Cardinal(AlphaTable) then Inc(Cardinal(alpha_ptr), 16); {$ENDIF} P := alpha_ptr; for I := 0 to 255 do begin L := I + I shl 16; P^ := L; Inc(P); P^ := L; Inc(P); P^ := L; Inc(P); P^ := L; Inc(P); end; bias_ptr := alpha_ptr; Inc(PLongWord(bias_ptr), 4 * $80); end; procedure FreeAlphaTable; begin FreeMem(AlphaTable); end; {$IFNDEF OMIT_MMX} { MMX versions } function BlendReg_MMX(F, B: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // blend foreground color (F) to a background color (B), // using alpha channel value of F {$IFDEF TARGET_x86} // EAX <- F // EDX <- B // Result := Fa * (Frgb - Brgb) + Brgb MOVD MM0,EAX PXOR MM3,MM3 MOVD MM2,EDX PUNPCKLBW MM0,MM3 MOV ECX,bias_ptr PUNPCKLBW MM2,MM3 MOVQ MM1,MM0 PUNPCKHWD MM1,MM1 PSUBW MM0,MM2 PUNPCKHDQ MM1,MM1 PSLLW MM2,8 PMULLW MM0,MM1 PADDW MM2,[ECX] PADDW MM2,MM0 PSRLW MM2,8 PACKUSWB MM2,MM3 MOVD EAX,MM2 {$ENDIF} {$IFDEF TARGET_x64} // ECX <- F // EDX <- B // Result := Fa * (Frgb - Brgb) + Brgb MOVD MM0,ECX PXOR MM3,MM3 MOVD MM2,EDX PUNPCKLBW MM0,MM3 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PUNPCKLBW MM2,MM3 MOVQ MM1,MM0 PUNPCKHWD MM1,MM1 PSUBW MM0,MM2 PUNPCKHDQ MM1,MM1 PSLLW MM2,8 PMULLW MM0,MM1 PADDW MM2,[RAX] PADDW MM2,MM0 PSRLW MM2,8 PACKUSWB MM2,MM3 MOVD EAX,MM2 {$ENDIF} end; {$IFDEF TARGET_x86} procedure BlendMem_MMX(F: TColor32; var B: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // EAX - Color X // [EDX] - Color Y // Result := W * (X - Y) + Y TEST EAX,$FF000000 JZ @1 CMP EAX,$FF000000 JNC @2 PXOR MM3,MM3 MOVD MM0,EAX MOVD MM2,[EDX] PUNPCKLBW MM0,MM3 MOV ECX,bias_ptr PUNPCKLBW MM2,MM3 MOVQ MM1,MM0 PUNPCKHWD MM1,MM1 PSUBW MM0,MM2 PUNPCKHDQ MM1,MM1 PSLLW MM2,8 PMULLW MM0,MM1 PADDW MM2,[ECX] PADDW MM2,MM0 PSRLW MM2,8 PACKUSWB MM2,MM3 MOVD [EDX],MM2 @1: RET @2: MOV [EDX],EAX end; function BlendRegEx_MMX(F, B, M: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // blend foreground color (F) to a background color (B), // using alpha channel value of F // EAX <- F // EDX <- B // ECX <- M // Result := M * Fa * (Frgb - Brgb) + Brgb PUSH EBX MOV EBX,EAX SHR EBX,24 INC ECX // 255:256 range bias IMUL ECX,EBX SHR ECX,8 JZ @1 PXOR MM0,MM0 MOVD MM1,EAX SHL ECX,4 MOVD MM2,EDX PUNPCKLBW MM1,MM0 PUNPCKLBW MM2,MM0 ADD ECX,alpha_ptr PSUBW MM1,MM2 PMULLW MM1,[ECX] PSLLW MM2,8 MOV ECX,bias_ptr PADDW MM2,[ECX] PADDW MM1,MM2 PSRLW MM1,8 PACKUSWB MM1,MM0 MOVD EAX,MM1 POP EBX RET @1: MOV EAX,EDX POP EBX end; {$ENDIF} procedure BlendMemEx_MMX(F: TColor32; var B:TColor32; M: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // blend foreground color (F) to a background color (B), // using alpha channel value of F // EAX <- F // [EDX] <- B // ECX <- M // Result := M * Fa * (Frgb - Brgb) + Brgb TEST EAX,$FF000000 JZ @2 PUSH EBX MOV EBX,EAX SHR EBX,24 INC ECX // 255:256 range bias IMUL ECX,EBX SHR ECX,8 JZ @1 PXOR MM0,MM0 MOVD MM1,EAX SHL ECX,4 MOVD MM2,[EDX] PUNPCKLBW MM1,MM0 PUNPCKLBW MM2,MM0 ADD ECX,alpha_ptr PSUBW MM1,MM2 PMULLW MM1,[ECX] PSLLW MM2,8 MOV ECX,bias_ptr PADDW MM2,[ECX] PADDW MM1,MM2 PSRLW MM1,8 PACKUSWB MM1,MM0 MOVD [EDX],MM1 @1: POP EBX @2: {$ENDIF} {$IFDEF TARGET_x64} // blend foreground color (F) to a background color (B), // using alpha channel value of F // ECX <- F // [EDX] <- B // R8 <- M // Result := M * Fa * (Frgb - Brgb) + Brgb TEST ECX,$FF000000 JZ @1 MOV EAX,ECX SHR EAX,24 INC R8D // 255:256 range bias IMUL R8D,EAX SHR R8D,8 JZ @1 PXOR MM0,MM0 MOVD MM1,ECX SHL R8D,4 MOVD MM2,[RDX] PUNPCKLBW MM1,MM0 PUNPCKLBW MM2,MM0 {$IFNDEF FPC} ADD R8,alpha_ptr {$ELSE} ADD R8,[RIP+alpha_ptr] {$ENDIF} PSUBW MM1,MM2 PMULLW MM1,[R8] PSLLW MM2,8 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PADDW MM2,[RAX] PADDW MM1,MM2 PSRLW MM1,8 PACKUSWB MM1,MM0 MOVD [RDX],MM1 @1: {$ENDIF} end; function BlendRegRGB_MMX(F, B, W: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} PXOR MM2,MM2 MOVD MM0,EAX PUNPCKLBW MM0,MM2 MOVD MM1,EDX PUNPCKLBW MM1,MM2 BSWAP ECX PSUBW MM0,MM1 MOVD MM3,ECX PUNPCKLBW MM3,MM2 PMULLW MM0,MM3 MOV EAX,bias_ptr PSLLW MM1,8 PADDW MM1,[EAX] PADDW MM1,MM0 PSRLW MM1,8 PACKUSWB MM1,MM2 MOVD EAX,MM1 {$ENDIF} {$IFDEF TARGET_x64} PXOR MM2,MM2 MOVD MM0,ECX PUNPCKLBW MM0,MM2 MOVD MM1,EDX PUNPCKLBW MM1,MM2 BSWAP R8D PSUBW MM0,MM1 MOVD MM3,R8D PUNPCKLBW MM3,MM2 PMULLW MM0,MM3 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PSLLW MM1,8 PADDW MM1,[RAX] PADDW MM1,MM0 PSRLW MM1,8 PACKUSWB MM1,MM2 MOVD EAX,MM1 {$ENDIF} end; procedure BlendMemRGB_MMX(F: TColor32; var B: TColor32; W: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} PXOR MM2,MM2 MOVD MM0,EAX PUNPCKLBW MM0,MM2 MOVD MM1,[EDX] PUNPCKLBW MM1,MM2 BSWAP ECX PSUBW MM0,MM1 MOVD MM3,ECX PUNPCKLBW MM3,MM2 PMULLW MM0,MM3 MOV EAX,bias_ptr PSLLW MM1,8 PADDW MM1,[EAX] PADDW MM1,MM0 PSRLW MM1,8 PACKUSWB MM1,MM2 MOVD [EDX],MM1 {$ENDIF} {$IFDEF TARGET_x64} PXOR MM2,MM2 MOVD MM0,ECX PUNPCKLBW MM0,MM2 MOVD MM1,[EDX] PUNPCKLBW MM1,MM2 BSWAP R8D PSUBW MM0,MM1 MOVD MM3,R8D PUNPCKLBW MM3,MM2 PMULLW MM0,MM3 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PSLLW MM1,8 PADDW MM1,[RAX] PADDW MM1,MM0 PSRLW MM1,8 PACKUSWB MM1,MM2 MOVD [EDX],MM1 {$ENDIF} end; {$IFDEF TARGET_x86} procedure BlendLine_MMX(Src, Dst: PColor32; Count: Integer); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // EAX <- Src // EDX <- Dst // ECX <- Count // test the counter for zero or negativity TEST ECX,ECX JS @4 PUSH ESI PUSH EDI MOV ESI,EAX // ESI <- Src MOV EDI,EDX // EDI <- Dst // loop start @1: MOV EAX,[ESI] TEST EAX,$FF000000 JZ @3 // complete transparency, proceed to next point CMP EAX,$FF000000 JNC @2 // opaque pixel, copy without blending // blend MOVD MM0,EAX // MM0 <- 00 00 00 00 Fa Fr Fg Fb PXOR MM3,MM3 // MM3 <- 00 00 00 00 00 00 00 00 MOVD MM2,[EDI] // MM2 <- 00 00 00 00 Ba Br Bg Bb PUNPCKLBW MM0,MM3 // MM0 <- 00 Fa 00 Fr 00 Fg 00 Fb MOV EAX,bias_ptr PUNPCKLBW MM2,MM3 // MM2 <- 00 Ba 00 Br 00 Bg 00 Bb MOVQ MM1,MM0 // MM1 <- 00 Fa 00 Fr 00 Fg 00 Fb PUNPCKHWD MM1,MM1 // MM1 <- 00 Fa 00 Fa 00 ** 00 ** PSUBW MM0,MM2 // MM0 <- 00 Da 00 Dr 00 Dg 00 Db PUNPCKHDQ MM1,MM1 // MM1 <- 00 Fa 00 Fa 00 Fa 00 Fa PSLLW MM2,8 // MM2 <- Ba 00 Br 00 Bg 00 Bb 00 PMULLW MM0,MM1 // MM2 <- Pa ** Pr ** Pg ** Pb ** PADDW MM2,[EAX] // add bias PADDW MM2,MM0 // MM2 <- Qa ** Qr ** Qg ** Qb ** PSRLW MM2,8 // MM2 <- 00 Qa 00 Qr 00 Qg 00 Qb PACKUSWB MM2,MM3 // MM2 <- 00 00 00 00 Qa Qr Qg Qb MOVD EAX,MM2 @2: MOV [EDI],EAX @3: ADD ESI,4 ADD EDI,4 // loop end DEC ECX JNZ @1 POP EDI POP ESI @4: end; procedure BlendLineEx_MMX(Src, Dst: PColor32; Count: Integer; M: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // EAX <- Src // EDX <- Dst // ECX <- Count // test the counter for zero or negativity TEST ECX,ECX JS @4 PUSH ESI PUSH EDI PUSH EBX MOV ESI,EAX // ESI <- Src MOV EDI,EDX // EDI <- Dst MOV EDX,M // EDX <- Master Alpha // loop start @1: MOV EAX,[ESI] TEST EAX,$FF000000 JZ @3 // complete transparency, proceed to next point MOV EBX,EAX SHR EBX,24 INC EBX // 255:256 range bias IMUL EBX,EDX SHR EBX,8 JZ @3 // complete transparency, proceed to next point // blend PXOR MM0,MM0 MOVD MM1,EAX SHL EBX,4 MOVD MM2,[EDI] PUNPCKLBW MM1,MM0 PUNPCKLBW MM2,MM0 ADD EBX,alpha_ptr PSUBW MM1,MM2 PMULLW MM1,[EBX] PSLLW MM2,8 MOV EBX,bias_ptr PADDW MM2,[EBX] PADDW MM1,MM2 PSRLW MM1,8 PACKUSWB MM1,MM0 MOVD EAX,MM1 @2: MOV [EDI],EAX @3: ADD ESI,4 ADD EDI,4 // loop end DEC ECX JNZ @1 POP EBX POP EDI POP ESI @4: end; {$ENDIF} function CombineReg_MMX(X, Y, W: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} // EAX - Color X // EDX - Color Y // ECX - Weight of X [0..255] // Result := W * (X - Y) + Y MOVD MM1,EAX PXOR MM0,MM0 SHL ECX,4 MOVD MM2,EDX PUNPCKLBW MM1,MM0 PUNPCKLBW MM2,MM0 ADD ECX,alpha_ptr PSUBW MM1,MM2 PMULLW MM1,[ECX] PSLLW MM2,8 MOV ECX,bias_ptr PADDW MM2,[ECX] PADDW MM1,MM2 PSRLW MM1,8 PACKUSWB MM1,MM0 MOVD EAX,MM1 {$ENDIF} {$IFDEF TARGET_X64} // ECX - Color X // EDX - Color Y // R8 - Weight of X [0..255] // Result := W * (X - Y) + Y MOVD MM1,ECX PXOR MM0,MM0 SHL R8D,4 MOVD MM2,EDX PUNPCKLBW MM1,MM0 PUNPCKLBW MM2,MM0 {$IFNDEF FPC} ADD R8,alpha_ptr {$ELSE} ADD R8,[RIP+alpha_ptr] {$ENDIF} PSUBW MM1,MM2 PMULLW MM1,[R8] PSLLW MM2,8 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PADDW MM2,[RAX] PADDW MM1,MM2 PSRLW MM1,8 PACKUSWB MM1,MM0 MOVD EAX,MM1 {$ENDIF} end; procedure CombineMem_MMX(F: TColor32; var B: TColor32; W: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} // EAX - Color X // [EDX] - Color Y // ECX - Weight of X [0..255] // Result := W * (X - Y) + Y JCXZ @1 CMP ECX,$FF JZ @2 MOVD MM1,EAX PXOR MM0,MM0 SHL ECX,4 MOVD MM2,[EDX] PUNPCKLBW MM1,MM0 PUNPCKLBW MM2,MM0 ADD ECX,alpha_ptr PSUBW MM1,MM2 PMULLW MM1,[ECX] PSLLW MM2,8 MOV ECX,bias_ptr PADDW MM2,[ECX] PADDW MM1,MM2 PSRLW MM1,8 PACKUSWB MM1,MM0 MOVD [EDX],MM1 @1: RET @2: MOV [EDX],EAX {$ENDIF} {$IFDEF TARGET_x64} // ECX - Color X // [RDX] - Color Y // R8 - Weight of X [0..255] // Result := W * (X - Y) + Y TEST R8D,R8D // Set flags for R8 JZ @1 // W = 0 ? => Result := EDX CMP R8D,$FF JZ @2 MOVD MM1,ECX PXOR MM0,MM0 SHL R8D,4 MOVD MM2,[RDX] PUNPCKLBW MM1,MM0 PUNPCKLBW MM2,MM0 {$IFNDEF FPC} ADD R8,alpha_ptr {$ELSE} ADD R8,[RIP+alpha_ptr] {$ENDIF} PSUBW MM1,MM2 PMULLW MM1,[R8] PSLLW MM2,8 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PADDW MM2,[RAX] PADDW MM1,MM2 PSRLW MM1,8 PACKUSWB MM1,MM0 MOVD [RDX],MM1 @1: RET @2: MOV [RDX],RCX {$ENDIF} end; {$IFDEF TARGET_x86} procedure CombineLine_MMX(Src, Dst: PColor32; Count: Integer; W: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // EAX <- Src // EDX <- Dst // ECX <- Count // Result := W * (X - Y) + Y TEST ECX,ECX JS @3 PUSH EBX MOV EBX,W TEST EBX,EBX JZ @2 // weight is zero CMP EBX,$FF JZ @4 // weight = 255 => copy src to dst SHL EBX,4 ADD EBX,alpha_ptr MOVQ MM3,[EBX] MOV EBX,bias_ptr MOVQ MM4,[EBX] // loop start @1: MOVD MM1,[EAX] PXOR MM0,MM0 MOVD MM2,[EDX] PUNPCKLBW MM1,MM0 PUNPCKLBW MM2,MM0 PSUBW MM1,MM2 PMULLW MM1,MM3 PSLLW MM2,8 PADDW MM2,MM4 PADDW MM1,MM2 PSRLW MM1,8 PACKUSWB MM1,MM0 MOVD [EDX],MM1 ADD EAX,4 ADD EDX,4 DEC ECX JNZ @1 @2: POP EBX POP EBP @3: RET $0004 @4: CALL GR32_LowLevel.MoveLongword POP EBX end; {$ENDIF} procedure EMMS_MMX; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm EMMS end; function LightenReg_MMX(C: TColor32; Amount: Integer): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD MM0,EAX TEST EDX,EDX JL @1 IMUL EDX,$010101 MOVD MM1,EDX PADDUSB MM0,MM1 MOVD EAX,MM0 RET @1: NEG EDX IMUL EDX,$010101 MOVD MM1,EDX PSUBUSB MM0,MM1 MOVD EAX,MM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD MM0,ECX TEST EDX,EDX JL @1 IMUL EDX,$010101 MOVD MM1,EDX PADDUSB MM0,MM1 MOVD EAX,MM0 RET @1: NEG EDX IMUL EDX,$010101 MOVD MM1,EDX PSUBUSB MM0,MM1 MOVD EAX,MM0 {$ENDIF} end; { MMX Color algebra versions } function ColorAdd_MMX(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD MM0,EAX MOVD MM1,EDX PADDUSB MM0,MM1 MOVD EAX,MM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD MM0,ECX MOVD MM1,EDX PADDUSB MM0,MM1 MOVD EAX,MM0 {$ENDIF} end; function ColorSub_MMX(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD MM0,EAX MOVD MM1,EDX PSUBUSB MM0,MM1 MOVD EAX,MM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD MM0,ECX MOVD MM1,EDX PSUBUSB MM0,MM1 MOVD EAX,MM0 {$ENDIF} end; function ColorModulate_MMX(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} PXOR MM2,MM2 MOVD MM0,EAX PUNPCKLBW MM0,MM2 MOVD MM1,EDX PUNPCKLBW MM1,MM2 PMULLW MM0,MM1 PSRLW MM0,8 PACKUSWB MM0,MM2 MOVD EAX,MM0 {$ENDIF} {$IFDEF TARGET_X64} PXOR MM2,MM2 MOVD MM0,ECX PUNPCKLBW MM0,MM2 MOVD MM1,EDX PUNPCKLBW MM1,MM2 PMULLW MM0,MM1 PSRLW MM0,8 PACKUSWB MM0,MM2 MOVD EAX,MM0 {$ENDIF} end; function ColorMax_EMMX(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD MM0,EAX MOVD MM1,EDX PMAXUB MM0,MM1 MOVD EAX,MM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD MM0,ECX MOVD MM1,EDX PMAXUB MM0,MM1 MOVD EAX,MM0 {$ENDIF} end; function ColorMin_EMMX(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD MM0,EAX MOVD MM1,EDX PMINUB MM0,MM1 MOVD EAX,MM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD MM0,ECX MOVD MM1,EDX PMINUB MM0,MM1 MOVD EAX,MM0 {$ENDIF} end; function ColorDifference_MMX(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD MM0,EAX MOVD MM1,EDX MOVQ MM2,MM0 PSUBUSB MM0,MM1 PSUBUSB MM1,MM2 POR MM0,MM1 MOVD EAX,MM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD MM0,ECX MOVD MM1,EDX MOVQ MM2,MM0 PSUBUSB MM0,MM1 PSUBUSB MM1,MM2 POR MM0,MM1 MOVD EAX,MM0 {$ENDIF} end; function ColorExclusion_MMX(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} PXOR MM2,MM2 MOVD MM0,EAX PUNPCKLBW MM0,MM2 MOVD MM1,EDX PUNPCKLBW MM1,MM2 MOVQ MM3,MM0 PADDW MM0,MM1 PMULLW MM1,MM3 PSRLW MM1,7 PSUBUSW MM0,MM1 PACKUSWB MM0,MM2 MOVD EAX,MM0 {$ENDIF} {$IFDEF TARGET_X64} PXOR MM2,MM2 MOVD MM0,ECX PUNPCKLBW MM0,MM2 MOVD MM1,EDX PUNPCKLBW MM1,MM2 MOVQ MM3,MM0 PADDW MM0,MM1 PMULLW MM1,MM3 PSRLW MM1,7 PSUBUSW MM0,MM1 PACKUSWB MM0,MM2 MOVD EAX,MM0 {$ENDIF} end; function ColorScale_MMX(C, W: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} PXOR MM2,MM2 SHL EDX,4 MOVD MM0,EAX PUNPCKLBW MM0,MM2 ADD EDX,alpha_ptr PMULLW MM0,[EDX] PSRLW MM0,8 PACKUSWB MM0,MM2 MOVD EAX,MM0 {$ENDIF} {$IFDEF TARGET_X64} PXOR MM2,MM2 SHL RDX,4 MOVD MM0,ECX PUNPCKLBW MM0,MM2 {$IFNDEF FPC} ADD RDX,alpha_ptr {$ELSE} ADD RDX,[RIP+alpha_ptr] {$ENDIF} PMULLW MM0,[RDX] PSRLW MM0,8 PACKUSWB MM0,MM2 MOVD EAX,MM0 {$ENDIF} end; {$ENDIF} { SSE2 versions } {$IFNDEF OMIT_SSE2} function BlendReg_SSE2(F, B: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // blend foreground color (F) to a background color (B), // using alpha channel value of F // EAX <- F // EDX <- B // Result := Fa * (Frgb - Brgb) + Brgb {$IFDEF TARGET_x86} MOVD XMM0,EAX PXOR XMM3,XMM3 MOVD XMM2,EDX PUNPCKLBW XMM0,XMM3 MOV ECX,bias_ptr PUNPCKLBW XMM2,XMM3 MOVQ XMM1,XMM0 PSHUFLW XMM1,XMM1, $FF PSUBW XMM0,XMM2 PSLLW XMM2,8 PMULLW XMM0,XMM1 PADDW XMM2,[ECX] PADDW XMM2,XMM0 PSRLW XMM2,8 PACKUSWB XMM2,XMM3 MOVD EAX,XMM2 {$ENDIF} {$IFDEF TARGET_x64} MOVD XMM0,ECX PXOR XMM3,XMM3 MOVD XMM2,EDX PUNPCKLBW XMM0,XMM3 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PUNPCKLBW XMM2,XMM3 MOVQ XMM1,XMM0 PSHUFLW XMM1,XMM1, $FF PSUBW XMM0,XMM2 PSLLW XMM2,8 PMULLW XMM0,XMM1 PADDW XMM2,[RAX] PADDW XMM2,XMM0 PSRLW XMM2,8 PACKUSWB XMM2,XMM3 MOVD EAX,XMM2 {$ENDIF} end; procedure BlendMem_SSE2(F: TColor32; var B: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX - Color X // [EDX] - Color Y // Result := W * (X - Y) + Y TEST EAX,$FF000000 JZ @1 CMP EAX,$FF000000 JNC @2 PXOR XMM3,XMM3 MOVD XMM0,EAX MOVD XMM2,[EDX] PUNPCKLBW XMM0,XMM3 MOV ECX,bias_ptr PUNPCKLBW XMM2,XMM3 MOVQ XMM1,XMM0 PSHUFLW XMM1,XMM1, $FF PSUBW XMM0,XMM2 PSLLW XMM2,8 PMULLW XMM0,XMM1 PADDW XMM2,[ECX] PADDW XMM2,XMM0 PSRLW XMM2,8 PACKUSWB XMM2,XMM3 MOVD [EDX],XMM2 @1: RET @2: MOV [EDX], EAX {$ENDIF} {$IFDEF TARGET_x64} // ECX - Color X // [EDX] - Color Y // Result := W * (X - Y) + Y TEST ECX,$FF000000 JZ @1 CMP ECX,$FF000000 JNC @2 PXOR XMM3,XMM3 MOVD XMM0,ECX MOVD XMM2,[RDX] PUNPCKLBW XMM0,XMM3 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PUNPCKLBW XMM2,XMM3 MOVQ XMM1,XMM0 PSHUFLW XMM1,XMM1, $FF PSUBW XMM0,XMM2 PSLLW XMM2,8 PMULLW XMM0,XMM1 PADDW XMM2,[RAX] PADDW XMM2,XMM0 PSRLW XMM2,8 PACKUSWB XMM2,XMM3 MOVD [RDX],XMM2 @1: RET @2: MOV [RDX], ECX {$ENDIF} end; procedure BlendMems_SSE2(F: TColor32; B: PColor32; Count: Integer); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} TEST ECX,ECX JZ @Done TEST EAX,$FF000000 JZ @Done PUSH EBX MOV EBX,EAX SHR EBX,24 CMP EBX,$FF JZ @CopyPixel MOVD XMM4,EAX PXOR XMM3,XMM3 PUNPCKLBW XMM4,XMM3 MOV EBX,bias_ptr @LoopStart: MOVD XMM2,[EDX] PUNPCKLBW XMM2,XMM3 MOVQ XMM1,XMM4 PUNPCKLBW XMM1,XMM3 PUNPCKHWD XMM1,XMM1 MOVQ XMM0,XMM4 PSUBW XMM0,XMM2 PUNPCKHDQ XMM1,XMM1 PSLLW XMM2,8 PMULLW XMM0,XMM1 PADDW XMM2,[EBX] PADDW XMM2,XMM0 PSRLW XMM2,8 PACKUSWB XMM2,XMM3 MOVD [EDX],XMM2 @NextPixel: ADD EDX,4 DEC ECX JNZ @LoopStart POP EBX @Done: RET @CopyPixel: MOV [EDX],EAX ADD EDX,4 DEC ECX JNZ @CopyPixel POP EBX {$ENDIF} {$IFDEF TARGET_x64} TEST R8D,R8D JZ @Done TEST ECX,$FF000000 JZ @Done MOV RAX,RCX SHR EAX,24 CMP EAX,$FF JZ @CopyPixel MOVD XMM4,ECX PXOR XMM3,XMM3 PUNPCKLBW XMM4,XMM3 MOV RAX,bias_ptr @LoopStart: MOVD XMM2,[RDX] PUNPCKLBW XMM2,XMM3 MOVQ XMM1,XMM4 PUNPCKLBW XMM1,XMM3 PUNPCKHWD XMM1,XMM1 MOVQ XMM0,XMM4 PSUBW XMM0,XMM2 PUNPCKHDQ XMM1,XMM1 PSLLW XMM2,8 PMULLW XMM0,XMM1 PADDW XMM2,[RAX] PADDW XMM2,XMM0 PSRLW XMM2,8 PACKUSWB XMM2,XMM3 MOVD [RDX], XMM2 @NextPixel: ADD RDX,4 DEC R8D JNZ @LoopStart @Done: RET @CopyPixel: MOV [RDX],ECX ADD RDX,4 DEC R8D JNZ @CopyPixel {$ENDIF} end; function BlendRegEx_SSE2(F, B, M: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // blend foreground color (F) to a background color (B), // using alpha channel value of F // Result := M * Fa * (Frgb - Brgb) + Brgb {$IFDEF TARGET_x86} // EAX <- F // EDX <- B // ECX <- M PUSH EBX MOV EBX,EAX SHR EBX,24 INC ECX // 255:256 range bias IMUL ECX,EBX SHR ECX,8 JZ @1 PXOR XMM0,XMM0 MOVD XMM1,EAX SHL ECX,4 MOVD XMM2,EDX PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 ADD ECX,alpha_ptr PSUBW XMM1,XMM2 PMULLW XMM1,[ECX] PSLLW XMM2,8 MOV ECX,bias_ptr PADDW XMM2,[ECX] PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD EAX,XMM1 POP EBX RET @1: MOV EAX,EDX POP EBX {$ENDIF} {$IFDEF TARGET_x64} // ECX <- F // EDX <- B // R8D <- M MOV EAX,ECX SHR EAX,24 INC R8D // 255:256 range bias IMUL R8D,EAX SHR R8D,8 JZ @1 PXOR XMM0,XMM0 MOVD XMM1,ECX SHL R8D,4 MOVD XMM2,EDX PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 {$IFNDEF FPC} ADD R8,alpha_ptr {$ELSE} ADD R8,[RIP+alpha_ptr] {$ENDIF} PSUBW XMM1,XMM2 PMULLW XMM1,[R8] PSLLW XMM2,8 {$IFNDEF FPC} MOV R8,bias_ptr {$ELSE} MOV R8,[RIP+bias_ptr] {$ENDIF} PADDW XMM2,[R8] PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD EAX,XMM1 RET @1: MOV EAX,EDX {$ENDIF} end; procedure BlendMemEx_SSE2(F: TColor32; var B:TColor32; M: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // blend foreground color (F) to a background color (B), // using alpha channel value of F // EAX <- F // [EDX] <- B // ECX <- M // Result := M * Fa * (Frgb - Brgb) + Brgb TEST EAX,$FF000000 JZ @2 PUSH EBX MOV EBX,EAX SHR EBX,24 INC ECX // 255:256 range bias IMUL ECX,EBX SHR ECX,8 JZ @1 PXOR XMM0,XMM0 MOVD XMM1,EAX SHL ECX,4 MOVD XMM2,[EDX] PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 ADD ECX,alpha_ptr PSUBW XMM1,XMM2 PMULLW XMM1,[ECX] PSLLW XMM2,8 MOV ECX,bias_ptr PADDW XMM2,[ECX] PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD [EDX],XMM1 @1: POP EBX @2: {$ENDIF} {$IFDEF TARGET_x64} // blend foreground color (F) to a background color (B), // using alpha channel value of F // RCX <- F // [RDX] <- B // R8 <- M // Result := M * Fa * (Frgb - Brgb) + Brgb TEST ECX, $FF000000 JZ @1 MOV R9D,ECX SHR R9D,24 INC R8D // 255:256 range bias IMUL R8D,R9D SHR R8D,8 JZ @1 PXOR XMM0,XMM0 MOVD XMM1,ECX SHL R8D,4 MOVD XMM2,[RDX] PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 {$IFNDEF FPC} ADD R8,alpha_ptr {$ELSE} ADD R8,[RIP+alpha_ptr] {$ENDIF} PSUBW XMM1,XMM2 PMULLW XMM1,[R8] PSLLW XMM2,8 {$IFNDEF FPC} MOV R8,bias_ptr {$ELSE} MOV R8,[RIP+bias_ptr] {$ENDIF} PADDW XMM2,[R8] PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD DWORD PTR [RDX],XMM1 @1: {$ENDIF} end; function BlendRegRGB_SSE2(F, B, W: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} PXOR XMM2,XMM2 MOVD XMM0,EAX PUNPCKLBW XMM0,XMM2 MOVD XMM1,EDX PUNPCKLBW XMM1,XMM2 BSWAP ECX PSUBW XMM0,XMM1 MOVD XMM3,ECX PUNPCKLBW XMM3,XMM2 PMULLW XMM0,XMM3 MOV EAX,bias_ptr PSLLW XMM1,8 PADDW XMM1,[EAX] PADDW XMM1,XMM0 PSRLW XMM1,8 PACKUSWB XMM1,XMM2 MOVD EAX,XMM1 {$ENDIF} {$IFDEF TARGET_x64} PXOR XMM2,XMM2 MOVD XMM0,ECX PUNPCKLBW XMM0,XMM2 MOVD XMM1,EDX PUNPCKLBW XMM1,XMM2 BSWAP R8D PSUBW XMM0,XMM1 MOVD XMM3,R8D PUNPCKLBW XMM3,XMM2 PMULLW XMM0,XMM3 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PSLLW XMM1,8 PADDW XMM1,[RAX] PADDW XMM1,XMM0 PSRLW XMM1,8 PACKUSWB XMM1,XMM2 MOVD EAX,XMM1 {$ENDIF} end; procedure BlendMemRGB_SSE2(F: TColor32; var B: TColor32; W: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} PXOR XMM2,XMM2 MOVD XMM0,EAX PUNPCKLBW XMM0,XMM2 MOVD XMM1,[EDX] PUNPCKLBW XMM1,XMM2 BSWAP ECX PSUBW XMM0,XMM1 MOVD XMM3,ECX PUNPCKLBW XMM3,XMM2 PMULLW XMM0,XMM3 MOV EAX,bias_ptr PSLLW XMM1,8 PADDW XMM1,[EAX] PADDW XMM1,XMM0 PSRLW XMM1,8 PACKUSWB XMM1,XMM2 MOVD [EDX],XMM1 {$ENDIF} {$IFDEF TARGET_x64} MOVD XMM1,R8D PXOR XMM4,XMM4 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} MOVQ XMM5,[RAX] MOVD XMM0,ECX MOVD XMM2,[RDX] PUNPCKLBW XMM0,XMM4 PUNPCKLBW XMM1,XMM4 PUNPCKLBW XMM2,XMM4 PSHUFLW XMM1,XMM1,$1B // C = wA B - wB PMULLW XMM0,XMM1 PADDW XMM0,XMM5 PSRLW XMM0,8 PADDW XMM0,XMM2 PMULLW XMM2,XMM1 PADDW XMM2,XMM5 PSRLW XMM2,8 PSUBW XMM0,XMM2 PACKUSWB XMM0,XMM4 MOVD [RDX],XMM0 {$ENDIF} end; {$IFDEF TEST_BLENDMEMRGB128SSE4} procedure BlendMemRGB128_SSE4(F: TColor32; var B: TColor32; W: UInt64); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} MOVQ XMM1,W PXOR XMM4,XMM4 MOV ECX,[bias_ptr] MOVDQA XMM5,[ECX] MOVD XMM0,EAX PINSRD XMM0,EAX,1 MOVQ XMM2,[EDX].QWORD PUNPCKLBW XMM0,XMM4 PUNPCKLBW XMM1,XMM4 PUNPCKLBW XMM2,XMM4 PSHUFLW XMM1,XMM1,$1B PSHUFHW XMM1,XMM1,$1B // C = wA B - wB PMULLW XMM0,XMM1 PADDW XMM0,XMM5 PSRLW XMM0,8 PADDW XMM0,XMM2 PMULLW XMM2,XMM1 PADDW XMM2,XMM5 PSRLW XMM2,8 PSUBW XMM0,XMM2 PACKUSWB XMM0,XMM4 MOVQ [EDX].QWORD,XMM0 {$ENDIF} {$IFDEF TARGET_x64} MOVQ XMM1,R8 PXOR XMM4,XMM4 MOV RAX,[RIP+bias_ptr] MOVDQA XMM5,[RAX] MOVD XMM0,ECX PINSRD XMM0,ECX,1 MOVQ XMM2,[RDX].QWORD PUNPCKLBW XMM0,XMM4 PUNPCKLBW XMM1,XMM4 PUNPCKLBW XMM2,XMM4 PSHUFLW XMM1,XMM1,$1B PSHUFHW XMM1,XMM1,$1B // C = wA B - wB PMULLW XMM0,XMM1 PADDW XMM0,XMM5 PSRLW XMM0,8 PADDW XMM0,XMM2 PMULLW XMM2,XMM1 PADDW XMM2,XMM5 PSRLW XMM2,8 PSUBW XMM0,XMM2 PACKUSWB XMM0,XMM4 MOVQ [RDX].QWORD,XMM0 {$ENDIF} end; {$ENDIF} procedure BlendLine_SSE2(Src, Dst: PColor32; Count: Integer); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} {$IFDEF FPC} const COpaque: QWORD = $FF000000FF000000; {$ENDIF} asm {$IFDEF TARGET_X86} // EAX <- Src // EDX <- Dst // ECX <- Count TEST ECX,ECX JLE @3 PUSH EBX PXOR XMM4,XMM4 MOV EBX,[bias_ptr] MOVDQA XMM5,[EBX] POP EBX TEST ECX, 1 JZ @2 MOVD XMM0,[EAX] MOVD XMM2,[EDX] PUNPCKLBW XMM0,XMM4 PUNPCKLBW XMM2,XMM4 PSHUFLW XMM1,XMM0,$FF // premultiply source pixel by its alpha MOVQ XMM3,XMM1 PSRLQ XMM3,16 PMULLW XMM0,XMM3 PADDW XMM0,XMM5 PSRLW XMM0,8 PSLLQ XMM3,48 POR XMM0,XMM3 // C' = A' B' - aB' PMULLW XMM1,XMM2 PADDW XMM1,XMM5 PSRLW XMM1,8 PADDW XMM0,XMM2 PSUBW XMM0,XMM1 PACKUSWB XMM0,XMM4 MOVD [EDX], XMM0 @2: LEA EAX, [EAX + ECX * 4] LEA EDX, [EDX + ECX * 4] SHR ECX,1 JZ @3 NEG ECX @1: MOVQ XMM0,[EAX + ECX * 8].QWORD MOVQ XMM2,[EDX + ECX * 8].QWORD PUNPCKLBW XMM0,XMM4 PUNPCKLBW XMM2,XMM4 PSHUFLW XMM1,XMM0,$FF PSHUFHW XMM1,XMM1,$FF // premultiply source pixel by its alpha MOVDQA XMM3,XMM1 PSRLQ XMM3,16 PMULLW XMM0,XMM3 PADDW XMM0,XMM5 PSRLW XMM0,8 PSLLQ XMM3,48 POR XMM0,XMM3 // C' = A' + B' - aB' PMULLW XMM1,XMM2 PADDW XMM1,XMM5 PSRLW XMM1,8 PADDW XMM0,XMM2 PSUBW XMM0,XMM1 PACKUSWB XMM0,XMM4 MOVQ [EDX + ECX * 8].QWORD,XMM0 ADD ECX,1 JS @1 @3: {$ENDIF} {$IFDEF TARGET_X64} TEST R8D,R8D JLE @3 PXOR XMM4,XMM4 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} MOVDQA XMM5,[RAX] MOV R9D, R8D SHR R9D, 1 TEST R9D, R9D JZ @2 @1: MOVQ XMM0,[RCX].QWORD MOVQ RAX,XMM0 {$IFDEF FPC} AND RAX,[RIP+COpaque] JZ @1b CMP RAX,[RIP+COpaque] JZ @1a {$ENDIF} MOVQ XMM2,[RDX].QWORD PUNPCKLBW XMM0,XMM4 PUNPCKLBW XMM2,XMM4 PSHUFLW XMM1,XMM0,$FF PSHUFHW XMM1,XMM1,$FF // premultiply source pixel by its alpha MOVDQA XMM3,XMM1 PSRLQ XMM3,16 PMULLW XMM0,XMM3 PADDW XMM0,XMM5 PSRLW XMM0,8 PSLLQ XMM3,48 POR XMM0,XMM3 // C' = A' + B' - aB' PMULLW XMM1,XMM2 PADDW XMM1,XMM5 PSRLW XMM1,8 PADDW XMM0,XMM2 PSUBW XMM0,XMM1 PACKUSWB XMM0,XMM4 @1a: MOVQ [RDX].QWORD,XMM0 @1b: ADD RCX,8 ADD RDX,8 SUB R9D,1 JNZ @1 @2: AND R8D, 1 JZ @3 MOVD XMM0,[RCX] MOVD XMM2,[RDX] PUNPCKLBW XMM0,XMM4 PUNPCKLBW XMM2,XMM4 PSHUFLW XMM1,XMM0,$FF // premultiply source pixel by its alpha MOVQ XMM3,XMM1 PSRLQ XMM3,16 PMULLW XMM0,XMM3 PADDW XMM0,XMM5 PSRLW XMM0,8 PSLLQ XMM3,48 POR XMM0,XMM3 // C' = A' B' - aB' PMULLW XMM1,XMM2 PADDW XMM1,XMM5 PSRLW XMM1,8 PADDW XMM0,XMM2 PSUBW XMM0,XMM1 PACKUSWB XMM0,XMM4 MOVD [RDX], XMM0 @3: {$ENDIF} end; procedure BlendLineEx_SSE2(Src, Dst: PColor32; Count: Integer; M: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} // EAX <- Src // EDX <- Dst // ECX <- Count // test the counter for zero or negativity TEST ECX,ECX JS @4 PUSH ESI PUSH EDI PUSH EBX MOV ESI,EAX // ESI <- Src MOV EDI,EDX // EDI <- Dst MOV EDX,M // EDX <- Master Alpha // loop start @1: MOV EAX,[ESI] TEST EAX,$FF000000 JZ @3 // complete transparency, proceed to next point MOV EBX,EAX SHR EBX,24 INC EBX // 255:256 range bias IMUL EBX,EDX SHR EBX,8 JZ @3 // complete transparency, proceed to next point // blend PXOR XMM0,XMM0 MOVD XMM1,EAX SHL EBX,4 MOVD XMM2,[EDI] PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 ADD EBX,alpha_ptr PSUBW XMM1,XMM2 PMULLW XMM1,[EBX] PSLLW XMM2,8 MOV EBX,bias_ptr PADDW XMM2,[EBX] PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD EAX,XMM1 @2: MOV [EDI],EAX @3: ADD ESI,4 ADD EDI,4 // loop end DEC ECX JNZ @1 POP EBX POP EDI POP ESI @4: {$ENDIF} {$IFDEF TARGET_X64} // ECX <- Src // EDX <- Dst // R8D <- Count // R9D <- M // test the counter for zero or negativity TEST R8D,R8D JS @4 TEST R9D,R9D JZ @4 MOV R10,RCX // ESI <- Src // loop start @1: MOV ECX,[R10] TEST ECX,$FF000000 JZ @3 // complete transparency, proceed to next point MOV EAX,ECX SHR EAX,24 INC EAX // 255:256 range bias IMUL EAX,R9D SHR EAX,8 JZ @3 // complete transparency, proceed to next point // blend PXOR XMM0,XMM0 MOVD XMM1,ECX SHL EAX,4 MOVD XMM2,[RDX] PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 {$IFNDEF FPC} ADD RAX,alpha_ptr {$ELSE} ADD RAX,[RIP+alpha_ptr] {$ENDIF} PSUBW XMM1,XMM2 PMULLW XMM1,[RAX] PSLLW XMM2,8 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PADDW XMM2,[RAX] PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD ECX,XMM1 @2: MOV [RDX],ECX @3: ADD R10,4 ADD RDX,4 // loop end DEC R8D JNZ @1 @4: {$ENDIF} end; function CombineReg_SSE2(X, Y, W: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} // EAX - Color X // EDX - Color Y // ECX - Weight of X [0..255] // Result := W * (X - Y) + Y MOVD XMM1,EAX PXOR XMM0,XMM0 SHL ECX,4 MOVD XMM2,EDX PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 ADD ECX,alpha_ptr PSUBW XMM1,XMM2 PMULLW XMM1,[ECX] PSLLW XMM2,8 MOV ECX,bias_ptr PADDW XMM2,[ECX] PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD EAX,XMM1 {$ENDIF} {$IFDEF TARGET_X64} // ECX - Color X // EDX - Color Y // R8D - Weight of X [0..255] // Result := W * (X - Y) + Y MOVD XMM1,ECX PXOR XMM0,XMM0 SHL R8D,4 MOVD XMM2,EDX PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 {$IFNDEF FPC} ADD R8,alpha_ptr {$ELSE} ADD R8,[RIP+alpha_ptr] {$ENDIF} PSUBW XMM1,XMM2 PMULLW XMM1,[R8] PSLLW XMM2,8 {$IFNDEF FPC} MOV R8,bias_ptr {$ELSE} MOV R8,[RIP+bias_ptr] {$ENDIF} PADDW XMM2,[R8] PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD EAX,XMM1 {$ENDIF} end; procedure CombineMem_SSE2(F: TColor32; var B: TColor32; W: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} // EAX - Color X // [EDX] - Color Y // ECX - Weight of X [0..255] // Result := W * (X - Y) + Y JCXZ @1 CMP ECX,$FF JZ @2 MOVD XMM1,EAX PXOR XMM0,XMM0 SHL ECX,4 MOVD XMM2,[EDX] PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 ADD ECX,alpha_ptr PSUBW XMM1,XMM2 PMULLW XMM1,[ECX] PSLLW XMM2,8 MOV ECX,bias_ptr PADDW XMM2,[ECX] PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD [EDX],XMM1 @1: RET @2: MOV [EDX],EAX {$ENDIF} {$IFDEF TARGET_X64} // ECX - Color X // [RDX] - Color Y // R8D - Weight of X [0..255] // Result := W * (X - Y) + Y TEST R8D,R8D // Set flags for R8 JZ @1 // W = 0 ? => Result := EDX CMP R8D,$FF JZ @2 MOVD XMM1,ECX PXOR XMM0,XMM0 SHL R8D,4 MOVD XMM2,[RDX] PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 {$IFNDEF FPC} ADD R8,alpha_ptr {$ELSE} ADD R8,[RIP+alpha_ptr] {$ENDIF} PSUBW XMM1,XMM2 PMULLW XMM1,[R8] PSLLW XMM2,8 {$IFNDEF FPC} MOV RAX,bias_ptr {$ELSE} MOV RAX,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} PADDW XMM2,[RAX] PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD [RDX],XMM1 @1: RET @2: MOV [RDX],ECX {$ENDIF} end; procedure CombineLine_SSE2(Src, Dst: PColor32; Count: Integer; W: TColor32); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} // EAX <- Src // EDX <- Dst // ECX <- Count // Result := W * (X - Y) + Y TEST ECX,ECX JZ @3 PUSH EBX MOV EBX,W TEST EBX,EBX JZ @2 CMP EBX,$FF JZ @4 SHL EBX,4 ADD EBX,alpha_ptr MOVQ XMM3,[EBX] MOV EBX,bias_ptr MOVQ XMM4,[EBX] PXOR XMM0,XMM0 @1: MOVD XMM1,[EAX] MOVD XMM2,[EDX] PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 PSUBW XMM1,XMM2 PMULLW XMM1,XMM3 PSLLW XMM2,8 PADDW XMM2,XMM4 PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD [EDX],XMM1 ADD EAX,4 ADD EDX,4 DEC ECX JNZ @1 @2: POP EBX POP EBP @3: RET $0004 @4: SHL ECX,2 CALL Move POP EBX {$ENDIF} {$IFDEF TARGET_X64} // ECX <- Src // EDX <- Dst // R8D <- Count // Result := W * (X - Y) + Y TEST R8D,R8D JZ @2 TEST R9D,R9D JZ @2 CMP R9D,$FF JZ @3 SHL R9D,4 {$IFNDEF FPC} ADD R9,alpha_ptr {$ELSE} ADD R9,[RIP+alpha_ptr] {$ENDIF} MOVQ XMM3,[R9] {$IFNDEF FPC} MOV R9,bias_ptr {$ELSE} MOV R9,[RIP+bias_ptr] // XXX : Enabling PIC by relative offsetting for x64 {$ENDIF} MOVQ XMM4,[R9] PXOR XMM0,XMM0 @1: MOVD XMM1,[RCX] MOVD XMM2,[RDX] PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 PSUBW XMM1,XMM2 PMULLW XMM1,XMM3 PSLLW XMM2,8 PADDW XMM2,XMM4 PADDW XMM1,XMM2 PSRLW XMM1,8 PACKUSWB XMM1,XMM0 MOVD [RDX],XMM1 ADD RCX,4 ADD RDX,4 DEC R8D JNZ @1 @2: RET @3: SHL R8D,2 CALL Move {$ENDIF} end; function MergeReg_SSE2(F, B: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm { This is an implementation of the merge formula, as described in a paper by Bruce Wallace in 1981. Merging is associative, that is, A over (B over C) = (A over B) over C. The formula is, Ra = Fa + Ba - Fa * Ba Rc = (Fa (Fc - Bc * Ba) + Bc * Ba) / Ra where Rc is the resultant color, Ra is the resultant alpha, Fc is the foreground color, Fa is the foreground alpha, Bc is the background color, Ba is the background alpha. Implementation: Ra := 1 - (1 - Fa) * (1 - Ba); Wa := Fa / Ra; Rc := Bc + Wa * (Fc - Bc); // Rc := Bc + Wa * (Fc - Bc) (1 - Fa) * (1 - Ba) = 1 - Fa - Ba + Fa * Ba = (1 - Ra) } {$IFDEF TARGET_X86} TEST EAX,$FF000000 // foreground completely transparent => JZ @1 // result = background CMP EAX,$FF000000 // foreground completely opaque => JNC @2 // result = foreground TEST EDX,$FF000000 // background completely transparent => JZ @2 // result = foreground PXOR XMM7,XMM7 // XMM7 <- 00 MOVD XMM0,EAX // XMM0 <- Fa Fr Fg Fb SHR EAX,24 // EAX <- Fa ROR EDX,24 MOVZX ECX,DL // ECX <- Ba PUNPCKLBW XMM0,XMM7 // XMM0 <- 00 Fa 00 Fr 00 Fg 00 Fb SUB EAX,$FF // EAX <- (Fa - 1) XOR ECX,$FF // ECX <- (1 - Ba) IMUL ECX,EAX // ECX <- (Fa - 1) * (1 - Ba) = Ra - 1 IMUL ECX,$8081 // ECX <- Xa 00 00 00 ADD ECX,$8081*$FF*$FF SHR ECX,15 // ECX <- Ra MOV DL,CH // EDX <- Br Bg Bb Ra ROR EDX,8 // EDX <- Ra Br Bg Bb MOVD XMM1,EDX // XMM1 <- Ra Br Bg Bb PUNPCKLBW XMM1,XMM7 // XMM1 <- 00 Ra 00 Br 00 Bg 00 Bb SHL EAX,20 // EAX <- Fa 00 00 PSUBW XMM0,XMM1 // XMM0 <- ** Da ** Dr ** Dg ** Db ADD EAX,$0FF01000 PSLLW XMM0,4 XOR EDX,EDX // EDX <- 00 DIV ECX // EAX <- Fa / Ra = Wa MOVD XMM4,EAX // XMM3 <- Wa PSHUFLW XMM4,XMM4,$C0 // XMM3 <- 00 00 ** Wa ** Wa ** Wa PMULHW XMM0,XMM4 // XMM0 <- 00 00 ** Pr ** Pg ** Pb PADDW XMM0,XMM1 // XMM0 <- 00 Ra 00 Rr 00 Rg 00 Rb PACKUSWB XMM0,XMM7 // XMM0 <- Ra Rr Rg Rb MOVD EAX,XMM0 RET @1: MOV EAX,EDX @2: {$ENDIF} {$IFDEF TARGET_X64} TEST ECX,$FF000000 // foreground completely transparent => JZ @1 // result = background MOV EAX,ECX // EAX <- Fa CMP EAX,$FF000000 // foreground completely opaque => JNC @2 // result = foreground TEST EDX,$FF000000 // background completely transparent => JZ @2 // result = foreground PXOR XMM7,XMM7 // XMM7 <- 00 MOVD XMM0,EAX // XMM0 <- Fa Fr Fg Fb SHR EAX,24 // EAX <- Fa ROR EDX,24 MOVZX ECX,DL // ECX <- Ba PUNPCKLBW XMM0,XMM7 // XMM0 <- 00 Fa 00 Fr 00 Fg 00 Fb SUB EAX,$FF // EAX <- (Fa - 1) XOR ECX,$FF // ECX <- (1 - Ba) IMUL ECX,EAX // ECX <- (Fa - 1) * (1 - Ba) = Ra - 1 IMUL ECX,$8081 // ECX <- Xa 00 00 00 ADD ECX,$8081*$FF*$FF SHR ECX,15 // ECX <- Ra MOV DL,CH // EDX <- Br Bg Bb Ra ROR EDX,8 // EDX <- Ra Br Bg Bb MOVD XMM1,EDX // XMM1 <- Ra Br Bg Bb PUNPCKLBW XMM1,XMM7 // XMM1 <- 00 Ra 00 Br 00 Bg 00 Bb SHL EAX,20 // EAX <- Fa 00 00 PSUBW XMM0,XMM1 // XMM0 <- ** Da ** Dr ** Dg ** Db ADD EAX,$0FF01000 PSLLW XMM0,4 XOR EDX,EDX // EDX <- 00 DIV ECX // EAX <- Fa / Ra = Wa MOVD XMM4,EAX // XMM3 <- Wa PSHUFLW XMM4,XMM4,$C0 // XMM3 <- 00 00 ** Wa ** Wa ** Wa PMULHW XMM0,XMM4 // XMM0 <- 00 00 ** Pr ** Pg ** Pb PADDW XMM0,XMM1 // XMM0 <- 00 Ra 00 Rr 00 Rg 00 Rb PACKUSWB XMM0,XMM7 // XMM0 <- Ra Rr Rg Rb MOVD EAX,XMM0 RET @1: MOV EAX,EDX @2: {$ENDIF} end; procedure EMMS_SSE2; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm end; function LightenReg_SSE2(C: TColor32; Amount: Integer): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD XMM0,EAX TEST EDX,EDX JL @1 IMUL EDX,$010101 MOVD XMM1,EDX PADDUSB XMM0,XMM1 MOVD EAX,XMM0 RET @1: NEG EDX IMUL EDX,$010101 MOVD XMM1,EDX PSUBUSB XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD XMM0,ECX TEST EDX,EDX JL @1 IMUL EDX,$010101 MOVD XMM1,EDX PADDUSB XMM0,XMM1 MOVD EAX,XMM0 RET @1: NEG EDX IMUL EDX,$010101 MOVD XMM1,EDX PSUBUSB XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} end; { SSE2 Color algebra} function ColorAdd_SSE2(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD XMM0,EAX MOVD XMM1,EDX PADDUSB XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD XMM0,ECX MOVD XMM1,EDX PADDUSB XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} end; function ColorSub_SSE2(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD XMM0,EAX MOVD XMM1,EDX PSUBUSB XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD XMM0,ECX MOVD XMM1,EDX PSUBUSB XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} end; function ColorModulate_SSE2(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} PXOR XMM2,XMM2 MOVD XMM0,EAX PUNPCKLBW XMM0,XMM2 MOVD XMM1,EDX PUNPCKLBW XMM1,XMM2 PMULLW XMM0,XMM1 PSRLW XMM0,8 PACKUSWB XMM0,XMM2 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} PXOR XMM2,XMM2 MOVD XMM0,ECX PUNPCKLBW XMM0,XMM2 MOVD XMM1,EDX PUNPCKLBW XMM1,XMM2 PMULLW XMM0,XMM1 PSRLW XMM0,8 PACKUSWB XMM0,XMM2 MOVD EAX,XMM0 {$ENDIF} end; function ColorMax_SSE2(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD XMM0,EAX MOVD XMM1,EDX PMAXUB XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD XMM0,ECX MOVD XMM1,EDX PMAXUB XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} end; function ColorMin_SSE2(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD XMM0,EAX MOVD XMM1,EDX PMINUB XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD XMM0,ECX MOVD XMM1,EDX PMINUB XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} end; function ColorDifference_SSE2(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} MOVD XMM0,EAX MOVD XMM1,EDX MOVQ XMM2,XMM0 PSUBUSB XMM0,XMM1 PSUBUSB XMM1,XMM2 POR XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} MOVD XMM0,ECX MOVD XMM1,EDX MOVQ XMM2,XMM0 PSUBUSB XMM0,XMM1 PSUBUSB XMM1,XMM2 POR XMM0,XMM1 MOVD EAX,XMM0 {$ENDIF} end; function ColorExclusion_SSE2(C1, C2: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} PXOR XMM2,XMM2 MOVD XMM0,EAX PUNPCKLBW XMM0,XMM2 MOVD XMM1,EDX PUNPCKLBW XMM1,XMM2 MOVQ XMM3,XMM0 PADDW XMM0,XMM1 PMULLW XMM1,XMM3 PSRLW XMM1,7 PSUBUSW XMM0,XMM1 PACKUSWB XMM0,XMM2 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} PXOR XMM2,XMM2 MOVD XMM0,ECX PUNPCKLBW XMM0,XMM2 MOVD XMM1,EDX PUNPCKLBW XMM1,XMM2 MOVQ XMM3,XMM0 PADDW XMM0,XMM1 PMULLW XMM1,XMM3 PSRLW XMM1,7 PSUBUSW XMM0,XMM1 PACKUSWB XMM0,XMM2 MOVD EAX,XMM0 {$ENDIF} end; function ColorScale_SSE2(C, W: TColor32): TColor32; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_X86} PXOR XMM2,XMM2 SHL EDX,4 MOVD XMM0,EAX PUNPCKLBW XMM0,XMM2 ADD EDX,alpha_ptr PMULLW XMM0,[EDX] PSRLW XMM0,8 PACKUSWB XMM0,XMM2 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} PXOR XMM2,XMM2 SHL RDX,4 MOVD XMM0,ECX PUNPCKLBW XMM0,XMM2 {$IFNDEF FPC} ADD RDX,alpha_ptr {$ELSE} ADD RDX,[RIP+alpha_ptr] {$ENDIF} PMULLW XMM0,[RDX] PSRLW XMM0,8 PACKUSWB XMM0,XMM2 MOVD EAX,XMM0 {$ENDIF} end; {$ENDIF} {$ENDIF} { Misc stuff } function Lighten(C: TColor32; Amount: Integer): TColor32; begin Result := LightenReg(C, Amount); end; procedure MakeMergeTables; var I, J: Integer; const OneByteth : Double = 1 / 255; begin for J := 0 to 255 do begin DivTable[0, J] := 0; RcTable[0, J] := 0; end; for J := 0 to 255 do for I := 1 to 255 do begin DivTable[I, J] := Round(I * J * OneByteth); RcTable[I, J] := Round(J * 255 / I) end; end; const FID_EMMS = 0; FID_MERGEREG = 1; FID_MERGEMEM = 2; FID_MERGELINE = 3; FID_MERGEREGEX = 4; FID_MERGEMEMEX = 5; FID_MERGELINEEX = 6; FID_COMBINEREG = 7; FID_COMBINEMEM = 8; FID_COMBINELINE = 9; FID_BLENDREG = 10; FID_BLENDMEM = 11; FID_BLENDMEMS = 12; FID_BLENDLINE = 13; FID_BLENDREGEX = 14; FID_BLENDMEMEX = 15; FID_BLENDLINEEX = 16; FID_COLORMAX = 17; FID_COLORMIN = 18; FID_COLORAVERAGE = 19; FID_COLORADD = 20; FID_COLORSUB = 21; FID_COLORDIV = 22; FID_COLORMODULATE = 23; FID_COLORDIFFERENCE = 24; FID_COLOREXCLUSION = 25; FID_COLORSCALE = 26; FID_LIGHTEN = 27; FID_BLENDREGRGB = 28; FID_BLENDMEMRGB = 29; {$IFDEF TEST_BLENDMEMRGB128SSE4} FID_BLENDMEMRGB128 = 30; {$ENDIF} procedure RegisterBindings; begin BlendRegistry := NewRegistry('GR32_Blend bindings'); {$IFNDEF OMIT_MMX} BlendRegistry.RegisterBinding(FID_EMMS, @@EMMS); {$ENDIF} BlendRegistry.RegisterBinding(FID_MERGEREG, @@MergeReg); BlendRegistry.RegisterBinding(FID_MERGEMEM, @@MergeMem); BlendRegistry.RegisterBinding(FID_MERGELINE, @@MergeLine); BlendRegistry.RegisterBinding(FID_MERGEREGEX, @@MergeRegEx); BlendRegistry.RegisterBinding(FID_MERGEMEMEX, @@MergeMemEx); BlendRegistry.RegisterBinding(FID_MERGELINEEX, @@MergeLineEx); BlendRegistry.RegisterBinding(FID_COMBINEREG, @@CombineReg); BlendRegistry.RegisterBinding(FID_COMBINEMEM, @@CombineMem); BlendRegistry.RegisterBinding(FID_COMBINELINE, @@CombineLine); BlendRegistry.RegisterBinding(FID_BLENDREG, @@BlendReg); BlendRegistry.RegisterBinding(FID_BLENDMEM, @@BlendMem); BlendRegistry.RegisterBinding(FID_BLENDMEMS, @@BlendMems); BlendRegistry.RegisterBinding(FID_BLENDLINE, @@BlendLine); BlendRegistry.RegisterBinding(FID_BLENDREGEX, @@BlendRegEx); BlendRegistry.RegisterBinding(FID_BLENDMEMEX, @@BlendMemEx); BlendRegistry.RegisterBinding(FID_BLENDLINEEX, @@BlendLineEx); BlendRegistry.RegisterBinding(FID_COLORMAX, @@ColorMax); BlendRegistry.RegisterBinding(FID_COLORMIN, @@ColorMin); BlendRegistry.RegisterBinding(FID_COLORAVERAGE, @@ColorAverage); BlendRegistry.RegisterBinding(FID_COLORADD, @@ColorAdd); BlendRegistry.RegisterBinding(FID_COLORSUB, @@ColorSub); BlendRegistry.RegisterBinding(FID_COLORDIV, @@ColorDiv); BlendRegistry.RegisterBinding(FID_COLORMODULATE, @@ColorModulate); BlendRegistry.RegisterBinding(FID_COLORDIFFERENCE, @@ColorDifference); BlendRegistry.RegisterBinding(FID_COLOREXCLUSION, @@ColorExclusion); BlendRegistry.RegisterBinding(FID_COLORSCALE, @@ColorScale); BlendRegistry.RegisterBinding(FID_LIGHTEN, @@LightenReg); BlendRegistry.RegisterBinding(FID_BLENDREGRGB, @@BlendRegRGB); BlendRegistry.RegisterBinding(FID_BLENDMEMRGB, @@BlendMemRGB); {$IFDEF TEST_BLENDMEMRGB128SSE4} BlendRegistry.RegisterBinding(FID_BLENDMEMRGB128, @@BlendMemRGB128); {$ENDIF} // pure pascal BlendRegistry.Add(FID_EMMS, @EMMS_Pas); BlendRegistry.Add(FID_MERGEREG, @MergeReg_Pas); BlendRegistry.Add(FID_MERGEMEM, @MergeMem_Pas); BlendRegistry.Add(FID_MERGEMEMEX, @MergeMemEx_Pas); BlendRegistry.Add(FID_MERGEREGEX, @MergeRegEx_Pas); BlendRegistry.Add(FID_MERGELINE, @MergeLine_Pas); BlendRegistry.Add(FID_MERGELINEEX, @MergeLineEx_Pas); BlendRegistry.Add(FID_COLORDIV, @ColorDiv_Pas); BlendRegistry.Add(FID_COLORAVERAGE, @ColorAverage_Pas); BlendRegistry.Add(FID_COMBINEREG, @CombineReg_Pas); BlendRegistry.Add(FID_COMBINEMEM, @CombineMem_Pas); BlendRegistry.Add(FID_COMBINELINE, @CombineLine_Pas); BlendRegistry.Add(FID_BLENDREG, @BlendReg_Pas); BlendRegistry.Add(FID_BLENDMEM, @BlendMem_Pas); BlendRegistry.Add(FID_BLENDMEMS, @BlendMems_Pas); BlendRegistry.Add(FID_BLENDLINE, @BlendLine_Pas); BlendRegistry.Add(FID_BLENDREGEX, @BlendRegEx_Pas); BlendRegistry.Add(FID_BLENDMEMEX, @BlendMemEx_Pas); BlendRegistry.Add(FID_BLENDLINEEX, @BlendLineEx_Pas); BlendRegistry.Add(FID_COLORMAX, @ColorMax_Pas); BlendRegistry.Add(FID_COLORMIN, @ColorMin_Pas); BlendRegistry.Add(FID_COLORADD, @ColorAdd_Pas); BlendRegistry.Add(FID_COLORSUB, @ColorSub_Pas); BlendRegistry.Add(FID_COLORMODULATE, @ColorModulate_Pas); BlendRegistry.Add(FID_COLORDIFFERENCE, @ColorDifference_Pas); BlendRegistry.Add(FID_COLOREXCLUSION, @ColorExclusion_Pas); BlendRegistry.Add(FID_COLORSCALE, @ColorScale_Pas); BlendRegistry.Add(FID_LIGHTEN, @LightenReg_Pas); BlendRegistry.Add(FID_BLENDREGRGB, @BlendRegRGB_Pas); BlendRegistry.Add(FID_BLENDMEMRGB, @BlendMemRGB_Pas); {$IFNDEF PUREPASCAL} BlendRegistry.Add(FID_EMMS, @EMMS_ASM, []); BlendRegistry.Add(FID_COMBINEREG, @CombineReg_ASM, []); BlendRegistry.Add(FID_COMBINEMEM, @CombineMem_ASM, []); BlendRegistry.Add(FID_BLENDREG, @BlendReg_ASM, []); BlendRegistry.Add(FID_BLENDMEM, @BlendMem_ASM, []); BlendRegistry.Add(FID_BLENDMEMS, @BlendMems_ASM, []); BlendRegistry.Add(FID_BLENDREGEX, @BlendRegEx_ASM, []); BlendRegistry.Add(FID_BLENDMEMEX, @BlendMemEx_ASM, []); BlendRegistry.Add(FID_BLENDLINE, @BlendLine_ASM, []); BlendRegistry.Add(FID_LIGHTEN, @LightenReg_Pas, []); // no ASM version available {$IFNDEF OMIT_MMX} BlendRegistry.Add(FID_EMMS, @EMMS_MMX, [ciMMX]); BlendRegistry.Add(FID_COMBINEREG, @CombineReg_MMX, [ciMMX]); BlendRegistry.Add(FID_COMBINEMEM, @CombineMem_MMX, [ciMMX]); BlendRegistry.Add(FID_COMBINELINE, @CombineLine_MMX, [ciMMX]); BlendRegistry.Add(FID_BLENDREG, @BlendReg_MMX, [ciMMX]); BlendRegistry.Add(FID_BLENDMEM, @BlendMem_MMX, [ciMMX]); BlendRegistry.Add(FID_BLENDREGEX, @BlendRegEx_MMX, [ciMMX]); BlendRegistry.Add(FID_BLENDMEMEX, @BlendMemEx_MMX, [ciMMX]); BlendRegistry.Add(FID_BLENDLINE, @BlendLine_MMX, [ciMMX]); BlendRegistry.Add(FID_BLENDLINEEX, @BlendLineEx_MMX, [ciMMX]); BlendRegistry.Add(FID_COLORMAX, @ColorMax_EMMX, [ciEMMX]); BlendRegistry.Add(FID_COLORMIN, @ColorMin_EMMX, [ciEMMX]); BlendRegistry.Add(FID_COLORADD, @ColorAdd_MMX, [ciMMX]); BlendRegistry.Add(FID_COLORSUB, @ColorSub_MMX, [ciMMX]); BlendRegistry.Add(FID_COLORMODULATE, @ColorModulate_MMX, [ciMMX]); BlendRegistry.Add(FID_COLORDIFFERENCE, @ColorDifference_MMX, [ciMMX]); BlendRegistry.Add(FID_COLOREXCLUSION, @ColorExclusion_MMX, [ciMMX]); BlendRegistry.Add(FID_COLORSCALE, @ColorScale_MMX, [ciMMX]); BlendRegistry.Add(FID_LIGHTEN, @LightenReg_MMX, [ciMMX]); BlendRegistry.Add(FID_BLENDREGRGB, @BlendRegRGB_MMX, [ciMMX]); BlendRegistry.Add(FID_BLENDMEMRGB, @BlendMemRGB_MMX, [ciMMX]); {$ENDIF} {$IFNDEF OMIT_SSE2} BlendRegistry.Add(FID_EMMS, @EMMS_SSE2, [ciSSE2]); BlendRegistry.Add(FID_MERGEREG, @MergeReg_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COMBINEREG, @CombineReg_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COMBINEMEM, @CombineMem_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COMBINELINE, @CombineLine_SSE2, [ciSSE2]); BlendRegistry.Add(FID_BLENDREG, @BlendReg_SSE2, [ciSSE2]); BlendRegistry.Add(FID_BLENDMEM, @BlendMem_SSE2, [ciSSE2]); BlendRegistry.Add(FID_BLENDMEMS, @BlendMems_SSE2, [ciSSE2]); BlendRegistry.Add(FID_BLENDMEMEX, @BlendMemEx_SSE2, [ciSSE2]); BlendRegistry.Add(FID_BLENDLINE, @BlendLine_SSE2, [ciSSE2]); BlendRegistry.Add(FID_BLENDLINEEX, @BlendLineEx_SSE2, [ciSSE2]); BlendRegistry.Add(FID_BLENDREGEX, @BlendRegEx_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COLORMAX, @ColorMax_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COLORMIN, @ColorMin_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COLORADD, @ColorAdd_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COLORSUB, @ColorSub_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COLORMODULATE, @ColorModulate_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COLORDIFFERENCE, @ColorDifference_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COLOREXCLUSION, @ColorExclusion_SSE2, [ciSSE2]); BlendRegistry.Add(FID_COLORSCALE, @ColorScale_SSE2, [ciSSE2]); BlendRegistry.Add(FID_LIGHTEN, @LightenReg_SSE2, [ciSSE]); BlendRegistry.Add(FID_BLENDREGRGB, @BlendRegRGB_SSE2, [ciSSE2]); BlendRegistry.Add(FID_BLENDMEMRGB, @BlendMemRGB_SSE2, [ciSSE2]); {$IFDEF TEST_BLENDMEMRGB128SSE4} BlendRegistry.Add(FID_BLENDMEMRGB128, @BlendMemRGB128_SSE4, [ciSSE2]); {$ENDIF} {$ENDIF} {$IFNDEF TARGET_x64} BlendRegistry.Add(FID_MERGEREG, @MergeReg_ASM, []); {$ENDIF} {$ENDIF} BlendRegistry.RebindAll; end; initialization RegisterBindings; MakeMergeTables; {$IFNDEF PUREPASCAL} MMX_ACTIVE := (ciMMX in CPUFeatures); if [ciMMX, ciSSE2] * CPUFeatures <> [] then GenAlphaTable; {$ELSE} MMX_ACTIVE := False; {$ENDIF} finalization {$IFNDEF PUREPASCAL} if [ciMMX, ciSSE2] * CPUFeatures <> [] then FreeAlphaTable; {$ENDIF} end. |
Added src/graphics32/GR32_Blurs.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 | unit GR32_Blurs; (* BEGIN LICENSE BLOCK ********************************************************* * Version: MPL 1.1 * * * * The contents of this file are 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/ * * * * 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. * * * * Alternatively, the contents of this file may be used under the terms of the * * Free Pascal modified version of the GNU Lesser General Public License * * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * * of this license are applicable instead of those above. * * Please see the file LICENSE.txt for additional information concerning this * * license. * * * * The Original Code is GR32_Blurs. The Gaussian blur algorithm was inspired * * by code published by Mario Klingemann and has been used with his permission. * * See also http://incubator.quasimondo.com * * * * Copyright 2012 - Angus Johnson * * * * Version 5.0 (Last updated 25-Sep-2012) * * * * END LICENSE BLOCK ***********************************************************) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, {$ELSE} Windows, Types, {$ENDIF} SysUtils, Classes, Math, GR32; procedure GaussianBlur(Bmp32: TBitmap32; Radius: TFloat); overload; procedure GaussianBlur(Bmp32: TBitmap32; Radius: TFloat; const Bounds: TRect); overload; procedure GaussianBlur(Bmp32: TBitmap32; Radius: TFloat; const BlurRegion: TArrayOfFloatPoint); overload; procedure FastBlur(Bmp32: TBitmap32; Radius: TFloat); overload; procedure FastBlur(Bmp32: TBitmap32; Radius: TFloat; const Bounds: TRect); overload; procedure FastBlur(Bmp32: TBitmap32; Radius: TFloat; const BlurRegion: TArrayOfFloatPoint); overload; procedure MotionBlur(Bmp32: TBitmap32; Dist, AngleDeg: TFloat; Bidirectional: Boolean = True); overload; procedure MotionBlur(Bmp32: TBitmap32; Dist, AngleDeg: TFloat; const Bounds: TRect; Bidirectional: Boolean = True); overload; procedure MotionBlur(Bmp32: TBitmap32; Dist, AngleDeg: TFloat; const BlurRegion: TArrayOfFloatPoint; Bidirectional: Boolean = True); overload; implementation uses GR32_Blend, GR32_Resamplers, GR32_Polygons, GR32_LowLevel, GR32_VectorUtils, GR32_Transforms; type TSumRecInt64 = record B, G, R, A: Int64; Sum: Integer; end; TSumRecord = record B, G, R, A: Integer; Sum: Integer; end; const ChannelSize = 256; // ie 1 byte for each of A,R,G & B in TColor32 ChannelSizeMin1 = ChannelSize - 1; { GaussianBlur } {$R-} procedure GaussianBlur(Bmp32: TBitmap32; Radius: TFloat); begin GaussianBlur(Bmp32, Radius, Bmp32.BoundsRect); end; procedure GaussianBlur(Bmp32: TBitmap32; Radius: TFloat; const Bounds: TRect); var Q, I, J, X, Y, ImageWidth, RowOffset, RadiusI: Integer; RecLeft, RecTop, RecRight, RecBottom: Integer; ImagePixels: PColor32EntryArray; RadiusSq, RadiusRevSq, KernelSize: Integer; SumRec: TSumRecInt64; PreMulArray: array of TColor32Entry; SumArray: array of TSumRecInt64; GaussLUT: array of array of Cardinal; begin RadiusI := Round(Radius); if RadiusI < 1 then Exit else if RadiusI > 128 then RadiusI := 128; // nb: performance degrades exponentially with >> Radius // initialize the look-up-table ... KernelSize := RadiusI * 2 + 1; SetLength(GaussLUT, KernelSize); for I := 0 to KernelSize - 1 do SetLength(GaussLUT[I], ChannelSize); for I := 1 to RadiusI do begin RadiusRevSq := Round((Radius + 1 - I) * (Radius + 1 - I)); for J := 0 to ChannelSizeMin1 do begin GaussLUT[RadiusI - I][J] := RadiusRevSq * J; GaussLUT[RadiusI + I][J] := GaussLUT[RadiusI - I][J]; end; end; RadiusSq := Round((Radius + 1) * (Radius + 1)); for J := 0 to ChannelSizeMin1 do GaussLUT[RadiusI][J] := RadiusSq * J; ImageWidth := Bmp32.Width; SetLength(SumArray, ImageWidth * Bmp32.Height); ImagePixels := PColor32EntryArray(Bmp32.Bits); RecLeft := Max(Bounds.Left, 0); RecTop := Max(Bounds.Top, 0); RecRight := Min(Bounds.Right, ImageWidth - 1); RecBottom := Min(Bounds.Bottom, Bmp32.Height - 1); RowOffset := RecTop * ImageWidth; SetLength(PreMulArray, Bmp32.Width); for Y := RecTop to RecBottom do begin // initialize PreMulArray for the row ... Q := (Y * ImageWidth) + RecLeft; for X := RecLeft to RecRight do with ImagePixels[Q] do begin PreMulArray[X].A := A; PreMulArray[X].R := DivTable[R, A]; PreMulArray[X].G := DivTable[G, A]; PreMulArray[X].B := DivTable[B, A]; Inc(Q); end; for X := RecLeft to RecRight do begin SumRec.A := 0; SumRec.R := 0; SumRec.G := 0; SumRec.B := 0; SumRec.Sum := 0; I := Max(X - RadiusI, RecLeft); Q := I - (X - RadiusI); for I := I to Min(X + RadiusI, RecRight) do with PreMulArray[I] do begin Inc(SumRec.A, GaussLUT[Q][A]); Inc(SumRec.R, GaussLUT[Q][R]); Inc(SumRec.G, GaussLUT[Q][G]); Inc(SumRec.B, GaussLUT[Q][B]); Inc(SumRec.Sum, GaussLUT[Q][1]); Inc(Q); end; Q := RowOffset + X; SumArray[Q].A := SumRec.A div SumRec.Sum; SumArray[Q].R := SumRec.R div SumRec.Sum; SumArray[Q].G := SumRec.G div SumRec.Sum; SumArray[Q].B := SumRec.B div SumRec.Sum; end; Inc(RowOffset, ImageWidth); end; RowOffset := RecTop * ImageWidth; for Y := RecTop to RecBottom do begin for X := RecLeft to RecRight do begin SumRec.A := 0; SumRec.R := 0; SumRec.G := 0; SumRec.B := 0; SumRec.Sum := 0; I := Max(Y - RadiusI, RecTop); Q := I - (Y - RadiusI); for I := I to Min(Y + RadiusI, RecBottom) do with SumArray[X + I * ImageWidth] do begin Inc(SumRec.A, GaussLUT[Q][A]); Inc(SumRec.R, GaussLUT[Q][R]); Inc(SumRec.G, GaussLUT[Q][G]); Inc(SumRec.B, GaussLUT[Q][B]); Inc(SumRec.Sum, GaussLUT[Q][1]); Inc(Q); end; with ImagePixels[RowOffset + X] do begin A := (SumRec.A div SumRec.Sum); R := RcTable[A, (SumRec.R div SumRec.Sum)]; G := RcTable[A, (SumRec.G div SumRec.Sum)]; B := RcTable[A, (SumRec.B div SumRec.Sum)]; end; end; Inc(RowOffset, ImageWidth); end; end; procedure GaussianBlur(Bmp32: TBitmap32; Radius: TFloat; const BlurRegion: TArrayOfFloatPoint); var Q, I, J, X, Y, ImageWidth, RowOffset, RadiusI: Integer; RecLeft, RecTop, RecRight, RecBottom: Integer; ImagePixels: PColor32EntryArray; RadiusSq, RadiusRevSq, KernelSize: Integer; SumRec: TSumRecInt64; SumArray: array of TSumRecInt64; GaussLUT: array of array of Cardinal; PreMulArray: array of TColor32Entry; Alpha: Cardinal; Mask: TBitmap32; Clr, MaskClr: TColor32Entry; Pts: TArrayOfFloatPoint; Bounds: TRect; begin with PolygonBounds(BlurRegion) do Bounds := Rect(Floor(Left), Floor(Top), Ceil(Right), Ceil(Bottom)); if Bounds.Left < 0 then Bounds.Left := 0; if Bounds.Top < 0 then Bounds.Top := 0; if Bounds.Right >= Bmp32.Width then Bounds.Right := Bmp32.Width - 1; if Bounds.Bottom >= Bmp32.Height then Bounds.Bottom := Bmp32.Height - 1; RadiusI := round(Radius); if (RadiusI < 1) or (Bounds.Right <= Bounds.Left) or (Bounds.Bottom <= Bounds.Top) then Exit else if RadiusI > 128 then RadiusI := 128; // nb: performance degrades exponentially with >> Radius Mask := TBitmap32.Create; try Mask.SetSize(Bounds.Right - Bounds.Left + 1, Bounds.Bottom - Bounds.Top + 1); SetLength(Pts, Length(BlurRegion)); for I := 0 to High(BlurRegion) do begin Pts[I].X := BlurRegion[I].X - Bounds.Left; Pts[I].Y := BlurRegion[I].Y - Bounds.Top; end; PolygonFS(Mask, Pts, clWhite32); // initialize the look-up-table ... KernelSize := RadiusI * 2 + 1; SetLength(GaussLUT, KernelSize); for I := 0 to KernelSize - 1 do SetLength(GaussLUT[I], ChannelSize); for I := 1 to RadiusI do begin RadiusRevSq := Round((Radius + 1 - I) * (Radius + 1 - I)); for J := 0 to ChannelSizeMin1 do begin GaussLUT[RadiusI - I][J] := RadiusRevSq * J; GaussLUT[RadiusI + I][J] := GaussLUT[RadiusI - I][J]; end; end; RadiusSq := Round((Radius + 1) * (Radius + 1)); for J := 0 to ChannelSizeMin1 do GaussLUT[RadiusI][J] := RadiusSq * J; ImageWidth := Bmp32.Width; SetLength(SumArray, ImageWidth * Bmp32.Height); ImagePixels := PColor32EntryArray(Bmp32.Bits); RecLeft := Max(Bounds.Left, 0); RecTop := Max(Bounds.Top, 0); RecRight := Min(Bounds.Right, ImageWidth - 1); RecBottom := Min(Bounds.Bottom, Bmp32.Height - 1); RowOffset := RecTop * ImageWidth; SetLength(PreMulArray, Bmp32.Width); for Y := RecTop to RecBottom do begin // initialize PreMulArray for the current row ... Q := (Y * ImageWidth) + RecLeft; for X := RecLeft to RecRight do with ImagePixels[Q] do begin PreMulArray[X].A := A; PreMulArray[X].R := DivTable[R, A]; PreMulArray[X].G := DivTable[G, A]; PreMulArray[X].B := DivTable[B, A]; Inc(Q); end; for X := RecLeft to RecRight do begin SumRec.A := 0; SumRec.R := 0; SumRec.G := 0; SumRec.B := 0; SumRec.Sum := 0; I := Max(X - RadiusI, RecLeft); Q := I - (X - RadiusI); for I := I to Min(X + RadiusI, RecRight) do with PreMulArray[I] do begin Inc(SumRec.A, GaussLUT[Q][A]); Inc(SumRec.R, GaussLUT[Q][R]); Inc(SumRec.G, GaussLUT[Q][G]); Inc(SumRec.B, GaussLUT[Q][B]); Inc(SumRec.Sum, GaussLUT[Q][1]); Inc(Q); end; Q := RowOffset + X; SumArray[Q].A := SumRec.A div SumRec.Sum; SumArray[Q].R := SumRec.R div SumRec.Sum; SumArray[Q].G := SumRec.G div SumRec.Sum; SumArray[Q].B := SumRec.B div SumRec.Sum; end; Inc(RowOffset, ImageWidth); end; RowOffset := RecTop * ImageWidth; for Y := RecTop to RecBottom do begin for X := RecLeft to RecRight do begin MaskClr.ARGB := Mask.Pixel[X - RecLeft, Y - RecTop]; if (MaskClr.A = 0) then Continue; SumRec.A := 0; SumRec.R := 0; SumRec.G := 0; SumRec.B := 0; SumRec.Sum := 0; I := Max(Y - RadiusI, RecTop); Q := I - (Y - RadiusI); for I := I to Min(Y + RadiusI, RecBottom) do with SumArray[X + I * ImageWidth] do begin Inc(SumRec.A, GaussLUT[Q][A]); Inc(SumRec.R, GaussLUT[Q][R]); Inc(SumRec.G, GaussLUT[Q][G]); Inc(SumRec.B, GaussLUT[Q][B]); Inc(SumRec.Sum, GaussLUT[Q][1]); Inc(Q); end; with ImagePixels[RowOffset + X] do if (MaskClr.A < 255) then begin Clr.A := SumRec.A div SumRec.Sum; Clr.R := RcTable[Clr.A, SumRec.R div SumRec.Sum]; Clr.G := RcTable[Clr.A, SumRec.G div SumRec.Sum]; Clr.B := RcTable[Clr.A, SumRec.B div SumRec.Sum]; BlendMemEx(Clr.ARGB, ARGB, MaskClr.A); end else begin A := SumRec.A div SumRec.Sum; R := RcTable[A, SumRec.R div SumRec.Sum]; G := RcTable[A, SumRec.G div SumRec.Sum]; B := RcTable[A, SumRec.B div SumRec.Sum]; end; end; Inc(RowOffset, ImageWidth); end; EMMS; finally Mask.Free; end; end; { FastBlur } procedure FastBlur(Bmp32: TBitmap32; Radius: TFloat); begin FastBlur(Bmp32, Radius, Bmp32.BoundsRect); end; procedure FastBlur(Bmp32: TBitmap32; Radius: TFloat; const Bounds: TRect); var LL, RR, TT, BB, XX, YY, I, J, X, Y, RadiusI, Passes: Integer; RecLeft, RecTop, RecRight, RecBottom: Integer; ImagePixel: PColor32Entry; SumRec: TSumRecord; ImgPixel: PColor32Entry; Pixels: array of TColor32Entry; begin if Radius < 1 then Exit else if Radius > 256 then Radius := 256; RadiusI := Round(Radius / Sqrt(-2 * Ln(1 / 255))); if RadiusI < 2 then begin Passes := Round(Radius); RadiusI := 1; end else Passes := 3; RecLeft := Max(Bounds.Left, 0); RecTop := Max(Bounds.Top, 0); RecRight := Min(Bounds.Right, Bmp32.Width - 1); RecBottom := Min(Bounds.Bottom, Bmp32.Height - 1); SetLength(Pixels, Max(Bmp32.Width, Bmp32.Height) + 1); // pre-multiply alphas ... for Y := RecTop to RecBottom do begin ImgPixel := PColor32Entry(Bmp32.ScanLine[Y]); Inc(ImgPixel, RecLeft); for X := RecLeft to RecRight do with ImgPixel^ do begin R := DivTable[R, A]; G := DivTable[G, A]; B := DivTable[B, A]; Inc(ImgPixel); end; end; for I := 1 to Passes do begin // horizontal pass... for Y := RecTop to RecBottom do begin ImagePixel := PColor32Entry(@Bmp32.ScanLine[Y][RecLeft]); // fill the Pixels buffer with a copy of the row's pixels ... MoveLongword(ImagePixel^, Pixels[RecLeft], RecRight - RecLeft + 1); SumRec.A := 0; SumRec.R := 0; SumRec.G := 0; SumRec.B := 0; SumRec.Sum := 0; LL := RecLeft; RR := RecLeft + RadiusI; if RR > RecRight then RR := RecRight; // update first in row ... for XX := LL to RR do with Pixels[XX] do begin Inc(SumRec.A, A); Inc(SumRec.R, R); Inc(SumRec.G, G); Inc(SumRec.B, B); Inc(SumRec.Sum); end; with ImagePixel^ do begin A := SumRec.A div SumRec.Sum; R := SumRec.R div SumRec.Sum; G := SumRec.G div SumRec.Sum; B := SumRec.B div SumRec.Sum; end; // update the remaining pixels in the row ... for X := RecLeft + 1 to RecRight do begin Inc(ImagePixel); LL := X - RadiusI - 1; RR := X + RadiusI; if LL >= RecLeft then with Pixels[LL] do begin Dec(SumRec.A, A); Dec(SumRec.R, R); Dec(SumRec.G, G); Dec(SumRec.B, B); Dec(SumRec.Sum); end; if RR <= RecRight then with Pixels[RR] do begin Inc(SumRec.A, A); Inc(SumRec.R, R); Inc(SumRec.G, G); Inc(SumRec.B, B); Inc(SumRec.Sum); end; with ImagePixel^ do begin A := SumRec.A div SumRec.Sum; R := SumRec.R div SumRec.Sum; G := SumRec.G div SumRec.Sum; B := SumRec.B div SumRec.Sum; end; end; end; // vertical pass... for X := RecLeft to RecRight do begin ImagePixel := PColor32Entry(@Bmp32.ScanLine[RecTop][X]); for J := RecTop to RecBottom do begin Pixels[J] := ImagePixel^; Inc(ImagePixel, Bmp32.Width); end; ImagePixel := PColor32Entry(@Bmp32.ScanLine[RecTop][X]); TT := RecTop; BB := RecTop + RadiusI; if BB > RecBottom then BB := RecBottom; SumRec.A := 0; SumRec.R := 0; SumRec.G := 0; SumRec.B := 0; SumRec.Sum := 0; // update first in col ... for YY := TT to BB do with Pixels[YY] do begin Inc(SumRec.A, A); Inc(SumRec.R, R); Inc(SumRec.G, G); Inc(SumRec.B, B); Inc(SumRec.Sum); end; with ImagePixel^ do begin A := SumRec.A div SumRec.Sum; R := SumRec.R div SumRec.Sum; G := SumRec.G div SumRec.Sum; B := SumRec.B div SumRec.Sum; end; // update remainder in col ... for Y := RecTop + 1 to RecBottom do begin Inc(ImagePixel, Bmp32.Width); TT := Y - RadiusI - 1; BB := Y + RadiusI; if TT >= RecTop then with Pixels[TT] do begin Dec(SumRec.A, A); Dec(SumRec.R, R); Dec(SumRec.G, G); Dec(SumRec.B, B); Dec(SumRec.Sum); end; if BB <= RecBottom then with Pixels[BB] do begin Inc(SumRec.A, A); Inc(SumRec.R, R); Inc(SumRec.G, G); Inc(SumRec.B, B); Inc(SumRec.Sum); end; with ImagePixel^ do begin A := SumRec.A div SumRec.Sum; R := SumRec.R div SumRec.Sum; G := SumRec.G div SumRec.Sum; B := SumRec.B div SumRec.Sum; end; end; end; end; // extract alphas ... for Y := RecTop to RecBottom do begin ImgPixel := PColor32Entry(@Bmp32.ScanLine[Y][RecLeft]); for X := RecLeft to RecRight do begin ImgPixel.R := RcTable[ImgPixel.A, ImgPixel.R]; ImgPixel.G := RcTable[ImgPixel.A, ImgPixel.G]; ImgPixel.B := RcTable[ImgPixel.A, ImgPixel.B]; Inc(ImgPixel); end; end; end; procedure FastBlur(Bmp32: TBitmap32; Radius: TFloat; const BlurRegion: TArrayOfFloatPoint); var LL, RR, TT, BB, XX, YY, I, J, X, Y, RadiusI, Passes: Integer; RecLeft, RecTop, RecRight, RecBottom: Integer; ImagePixel: PColor32Entry; SumRec: TSumRecord; ImgPixel: PColor32Entry; Pixels: array of TSumRecord; Mask: TBitmap32; Clr, MaskClr: TColor32Entry; Pts: TArrayOfFloatPoint; Bounds: TRect; begin if Radius < 1 then Exit else if Radius > 256 then Radius := 256; RadiusI := Round(Radius / Sqrt(-2 * Ln(1 / 255))); if RadiusI < 2 then begin Passes := Round(Radius); RadiusI := 1; end else Passes := 3; with PolygonBounds(BlurRegion) do Bounds := Rect(Floor(Left), Floor(Top), Ceil(Right), Ceil(Bottom)); if Bounds.Left < 0 then Bounds.Left := 0; if Bounds.Top < 0 then Bounds.Top := 0; if Bounds.Right >= Bmp32.Width then Bounds.Right := Bmp32.Width - 1; if Bounds.Bottom >= Bmp32.Height then Bounds.Bottom := Bmp32.Height - 1; RecLeft := Max(Bounds.Left, 0); RecTop := Max(Bounds.Top, 0); RecRight := Min(Bounds.Right, Bmp32.Width - 1); RecBottom := Min(Bounds.Bottom, Bmp32.Height - 1); SetLength(Pixels, Max(Bmp32.Width, Bmp32.Height) + 1); // pre-multiply alphas ... for Y := RecTop to RecBottom do begin ImgPixel := PColor32Entry(Bmp32.ScanLine[Y]); Inc(ImgPixel, RecLeft); for X := RecLeft to RecRight do begin ImgPixel.R := DivTable[ImgPixel.R, ImgPixel.A]; ImgPixel.G := DivTable[ImgPixel.G, ImgPixel.A]; ImgPixel.B := DivTable[ImgPixel.B, ImgPixel.A]; Inc(ImgPixel); end; end; Mask := TBitmap32.Create; try Mask.SetSize(Bounds.Right - Bounds.Left + 1, Bounds.Bottom - Bounds.Top + 1); SetLength(Pts, Length(BlurRegion)); for I := 0 to High(BlurRegion) do begin Pts[I].X := BlurRegion[I].X - Bounds.Left; Pts[I].Y := BlurRegion[I].Y - Bounds.Top; end; PolygonFS(Mask, Pts, clWhite32); for I := 1 to Passes do begin // horizontal pass... for Y := RecTop to RecBottom do begin ImagePixel := PColor32Entry(@Bmp32.ScanLine[Y][RecLeft]); // fill the Pixels buffer with a copy of the row's pixels ... for J := RecLeft to RecRight do begin MaskClr.ARGB := Mask.Pixel[J - RecLeft, Y - RecTop]; if (MaskClr.A = 0) then begin Pixels[J].A := 0; Pixels[J].R := 0; Pixels[J].G := 0; Pixels[J].B := 0; Pixels[J].Sum := 0; end else with ImagePixel^ do begin Pixels[J].A := A; Pixels[J].R := R; Pixels[J].G := G; Pixels[J].B := B; Pixels[J].Sum := 1; end; Inc(ImagePixel); end; LL := RecLeft; RR := RecLeft + RadiusI; if RR > RecRight then RR := RecRight; SumRec.A := 0; SumRec.R := 0; SumRec.G := 0; SumRec.B := 0; SumRec.Sum := 0; // update first in row ... for XX := LL to RR do with Pixels[XX] do begin Inc(SumRec.A, A); Inc(SumRec.R, R); Inc(SumRec.G, G); Inc(SumRec.B, B); Inc(SumRec.Sum, Sum); end; ImagePixel := PColor32Entry(@Bmp32.ScanLine[Y][RecLeft]); MaskClr.ARGB := Mask.Pixel[0, Y - RecTop]; if (MaskClr.A > 0) and (SumRec.Sum > 0) then with ImagePixel^ do begin A := SumRec.A div SumRec.Sum; R := SumRec.R div SumRec.Sum; G := SumRec.G div SumRec.Sum; B := SumRec.B div SumRec.Sum; end; // update the remaining pixels in the row ... for X := RecLeft + 1 to RecRight do begin Inc(ImagePixel); LL := X - RadiusI - 1; RR := X + RadiusI; if LL >= RecLeft then with Pixels[LL] do begin Dec(SumRec.A, A); Dec(SumRec.R, R); Dec(SumRec.G, G); Dec(SumRec.B, B); Dec(SumRec.Sum, Sum); end; if RR <= RecRight then with Pixels[RR] do begin Inc(SumRec.A, A); Inc(SumRec.R, R); Inc(SumRec.G, G); Inc(SumRec.B, B); Inc(SumRec.Sum, Sum); end; MaskClr.ARGB := Mask.Pixel[X - RecLeft, Y - RecTop]; with ImagePixel^ do if (SumRec.Sum > 0) and (MaskClr.A = 255) then begin A := SumRec.A div SumRec.Sum; R := SumRec.R div SumRec.Sum; G := SumRec.G div SumRec.Sum; B := SumRec.B div SumRec.Sum; end; end; end; // vertical pass... for X := RecLeft to RecRight do begin // fill the Pixels buffer with a copy of the col's pixels ... ImagePixel := PColor32Entry(@Bmp32.ScanLine[RecTop][X]); for J := RecTop to RecBottom do begin MaskClr.ARGB := Mask.Pixel[X - RecLeft, J - RecTop]; if (MaskClr.A = 0) then begin Pixels[J].A := 0; Pixels[J].R := 0; Pixels[J].G := 0; Pixels[J].B := 0; Pixels[J].Sum := 0; end else with ImagePixel^ do begin Pixels[J].A := A; Pixels[J].R := R; Pixels[J].G := G; Pixels[J].B := B; Pixels[J].Sum := 1; end; Inc(ImagePixel, Bmp32.Width); end; ImagePixel := PColor32Entry(@Bmp32.ScanLine[RecTop][X]); TT := RecTop; BB := RecTop + RadiusI; if BB > RecBottom then BB := RecBottom; SumRec.A := 0; SumRec.R := 0; SumRec.G := 0; SumRec.B := 0; SumRec.Sum := 0; // update first in col ... for YY := TT to BB do with Pixels[YY] do begin Inc(SumRec.A, A); Inc(SumRec.R, R); Inc(SumRec.G, G); Inc(SumRec.B, B); Inc(SumRec.Sum, Sum); end; MaskClr.ARGB := Mask.Pixel[X - RecLeft, 0]; if (MaskClr.A > 0) and (SumRec.Sum > 0) then with ImagePixel^ do begin A := SumRec.A div SumRec.Sum; R := SumRec.R div SumRec.Sum; G := SumRec.G div SumRec.Sum; B := SumRec.B div SumRec.Sum; end; // update remainder in col ... for Y := RecTop + 1 to RecBottom do begin Inc(ImagePixel, Bmp32.Width); TT := Y - RadiusI - 1; BB := Y + RadiusI; if TT >= RecTop then with Pixels[TT] do begin Dec(SumRec.A, A); Dec(SumRec.R, R); Dec(SumRec.G, G); Dec(SumRec.B, B); Dec(SumRec.Sum, Sum); end; if BB <= RecBottom then with Pixels[BB] do begin Inc(SumRec.A, A); Inc(SumRec.R, R); Inc(SumRec.G, G); Inc(SumRec.B, B); Inc(SumRec.Sum, Sum); end; MaskClr.ARGB := Mask.Pixel[X - RecLeft, Y - RecTop]; with ImagePixel^ do if (SumRec.Sum = 0) or (MaskClr.A = 0) then // do nothing else if (I = Passes) then begin Clr.A := SumRec.A div SumRec.Sum; Clr.R := SumRec.R div SumRec.Sum; Clr.G := SumRec.G div SumRec.Sum; Clr.B := SumRec.B div SumRec.Sum; BlendMemEx(Clr.ARGB, ARGB, MaskClr.A); end else if (MaskClr.A = 255) then begin A := SumRec.A div SumRec.Sum; R := SumRec.R div SumRec.Sum; G := SumRec.G div SumRec.Sum; B := SumRec.B div SumRec.Sum; end end; EMMS; end; end; // extract alphas ... for Y := RecTop to RecBottom do begin ImgPixel := PColor32Entry(Bmp32.ScanLine[Y]); Inc(ImgPixel, RecLeft); for X := RecLeft to RecRight do begin ImgPixel.R := RcTable[ImgPixel.A, ImgPixel.R]; ImgPixel.G := RcTable[ImgPixel.A, ImgPixel.G]; ImgPixel.B := RcTable[ImgPixel.A, ImgPixel.B]; Inc(ImgPixel); end; end; finally Mask.Free; end; end; procedure MotionBlur(Bmp32: TBitmap32; Dist, AngleDeg: TFloat; const Bounds: TRect; Bidirectional: Boolean = True); var Pts: TArrayOfFloatPoint; begin SetLength(Pts, 4); with Bounds do begin Pts[0] := FloatPoint(Left, Top); Pts[1] := FloatPoint(Right, Top); Pts[2] := FloatPoint(Right, Bottom); Pts[3] := FloatPoint(Left, Bottom); end; MotionBlur(Bmp32, Dist, AngleDeg, Pts, Bidirectional); end; procedure MotionBlur(Bmp32: TBitmap32; Dist, AngleDeg: TFloat; Bidirectional: Boolean = True); var Pts: TArrayOfFloatPoint; begin SetLength(Pts, 4); with Bmp32.BoundsRect do begin Pts[0] := FloatPoint(Left, Top); Pts[1] := FloatPoint(Right, Top); Pts[2] := FloatPoint(Right, Bottom); Pts[3] := FloatPoint(Left, Bottom); end; MotionBlur(Bmp32, Dist, AngleDeg, Pts, Bidirectional); end; procedure MotionBlur(Bmp32: TBitmap32; Dist, AngleDeg: TFloat; const BlurRegion: TArrayOfFloatPoint; Bidirectional: Boolean = True); var LL, RR, XX, I, X, Y, RadiusI, Passes: Integer; ImagePixel, ImagePixel2, ImagePixel3: PColor32Entry; ImagePixels, ImagePixels2: PColor32EntryArray; SumRec: TSumRecord; Pixels: array of TSumRecord; Mask: TBitmap32; Clr, MaskClr: TColor32Entry; Pts: TArrayOfFloatPoint; Bounds: TRect; Dx, Dy: Double; Affine: TAffineTransformation; BmpCutout: TBitmap32; BmpRotated: TBitmap32; PrevIsBlank, ThisIsBlank: boolean; begin if Dist < 1 then Exit else if Dist > 256 then Dist := 256; RadiusI := Round(Sqrt(-Dist * Dist / (2 * Ln(1 / 255)))); if RadiusI < 2 then begin Passes := Round(Dist); RadiusI := 1; end else Passes := 3; with PolygonBounds(BlurRegion) do Bounds := Rect(Floor(Left), Floor(Top), Ceil(Right), Ceil(Bottom)); Bounds.Left := Max(Bounds.Left, 0); Bounds.Top := Max(Bounds.Top, 0); Bounds.Right := Min(Bounds.Right, Bmp32.Width - 1); Bounds.Bottom := Min(Bounds.Bottom, Bmp32.Height - 1); Affine := TAffineTransformation.Create; BmpCutout := TBitmap32.Create; BmpRotated := TBitmap32.Create; BmpRotated.Resampler := TLinearResampler.Create(BmpRotated); Mask := TBitmap32.Create; try // copy the region to be blurred into the BmpCutout image buffer ... BmpCutout.SetSize(Bounds.Right - Bounds.Left, Bounds.Bottom - Bounds.Top); for Y := 0 to BmpCutout.Height - 1 do begin ImagePixel := PColor32Entry(@Bmp32.ScanLine[Y + Bounds.Top][Bounds.Left]); ImagePixel2 := PColor32Entry(BmpCutout.ScanLine[Y]); MoveLongword(ImagePixel^, ImagePixel2^, BmpCutout.Width); end; // pre-multiply alphas in BmpCutout ... for Y := 0 to BmpCutout.Height - 1 do begin ImagePixel := PColor32Entry(BmpCutout.ScanLine[Y]); for X := 0 to BmpCutout.Width - 1 do begin ImagePixel.R := DivTable[ImagePixel.R, ImagePixel.A]; ImagePixel.G := DivTable[ImagePixel.G, ImagePixel.A]; ImagePixel.B := DivTable[ImagePixel.B, ImagePixel.A]; Inc(ImagePixel); end; end; // Rotate BmpCutout into BmpRotated ... Affine.SrcRect := FloatRect(BmpCutout.BoundsRect); Affine.Rotate(180 - AngleDeg); with Affine.GetTransformedBounds do begin Mask.SetSize(Round(Right - Left) + 1, Round(Bottom - Top) + 1); BmpRotated.SetSize(Mask.Width, Mask.Height); Dx := Left; Dy := Top; Affine.Translate(-Dx, -Dy); end; Transform(BmpRotated, BmpCutout, Affine); // Create a rotated mask ... Affine.Clear; Affine.Translate(-Bounds.Left, -Bounds.Top); Affine.SrcRect := FloatRect(BmpCutout.BoundsRect); Affine.Rotate(180 - AngleDeg); Affine.Translate(-Dx, -Dy); Pts := TransformPolygon(BlurRegion, Affine); PolygonFS(Mask, Pts, clWhite32); SetLength(Pixels, BmpRotated.Width); // Now blur horizontally the rotated image ... for I := 1 to Passes do // Horizontal blur only ... for Y := 0 to BmpRotated.Height - 1 do begin ImagePixel := PColor32Entry(BmpRotated.ScanLine[Y]); // fill the Pixels buffer with a copy of the row's pixels ... for X := 0 to BmpRotated.Width - 1 do begin MaskClr.ARGB := Mask.Pixel[X, Y]; if (MaskClr.A = 0) then begin Pixels[X].A := 0; Pixels[X].R := 0; Pixels[X].G := 0; Pixels[X].B := 0; Pixels[X].Sum := 0; end else with ImagePixel^ do begin Pixels[X].A := A; Pixels[X].R := R; Pixels[X].G := G; Pixels[X].B := B; Pixels[X].Sum := 1; end; Inc(ImagePixel); end; LL := 0; RR := RadiusI; if RR >= BmpRotated.Width then RR := BmpRotated.Width - 1; SumRec.A := 0; SumRec.R := 0; SumRec.G := 0; SumRec.B := 0; SumRec.Sum := 0; // update first in row ... for XX := LL to RR do with Pixels[XX] do begin Inc(SumRec.A, A); Inc(SumRec.R, R); Inc(SumRec.G, G); Inc(SumRec.B, B); Inc(SumRec.Sum, Sum); end; ImagePixel := PColor32Entry(BmpRotated.ScanLine[Y]); MaskClr.ARGB := Mask.Pixel[0, Y]; if (MaskClr.A > 0) and (SumRec.Sum > 0) then with ImagePixel^ do begin A := SumRec.A div SumRec.Sum; R := SumRec.R div SumRec.Sum; G := SumRec.G div SumRec.Sum; B := SumRec.B div SumRec.Sum; end; // update the remaining pixels in the row ... for X := 1 to BmpRotated.Width - 1 do begin Inc(ImagePixel); if Bidirectional then LL := X - RadiusI - 1 else LL := X - 1; RR := X + RadiusI; if LL >= 0 then with Pixels[LL] do begin Dec(SumRec.A, A); Dec(SumRec.R, R); Dec(SumRec.G, G); Dec(SumRec.B, B); Dec(SumRec.Sum, Sum); end; if RR < BmpRotated.Width then with Pixels[RR] do begin Inc(SumRec.A, A); Inc(SumRec.R, R); Inc(SumRec.G, G); Inc(SumRec.B, B); Inc(SumRec.Sum, Sum); end; MaskClr.ARGB := Mask.Pixel[X, Y]; with ImagePixel^ do if (SumRec.Sum = 0) or (MaskClr.A = 0) then Continue else if (I = Passes) then begin Clr.A := SumRec.A div SumRec.Sum; Clr.R := SumRec.R div SumRec.Sum; Clr.G := SumRec.G div SumRec.Sum; Clr.B := SumRec.B div SumRec.Sum; BlendMemEx(Clr.ARGB, ARGB, MaskClr.A); end else if (MaskClr.A = 255) then begin A := SumRec.A div SumRec.Sum; R := SumRec.R div SumRec.Sum; G := SumRec.G div SumRec.Sum; B := SumRec.B div SumRec.Sum; end; end; EMMS; end; // un-rotate the now blurred image back into BmpCutout ... Affine.Clear; Affine.SrcRect := FloatRect(BmpRotated.BoundsRect); Affine.Translate(Dx, Dy); Affine.Rotate(AngleDeg + 180); Transform(BmpCutout, BmpRotated, Affine); // extract alphas ... for Y := 0 to BmpCutout.Height - 1 do begin ImagePixel := PColor32Entry(BmpCutout.ScanLine[Y]); for X := 0 to BmpCutout.Width - 1 do begin ImagePixel.R := RcTable[ImagePixel.A, ImagePixel.R]; ImagePixel.G := RcTable[ImagePixel.A, ImagePixel.G]; ImagePixel.B := RcTable[ImagePixel.A, ImagePixel.B]; Inc(ImagePixel); end; end; // Create an un-rotated mask and copy masked pixels from BmpCutout // back to the original image (Bmp32) ... Mask.SetSize(BmpCutout.Width, BmpCutout.Height); Pts := TranslatePolygon(BlurRegion, -Bounds.Left, -Bounds.Top); PolygonFS(Mask, Pts, clWhite32); for Y := 0 to BmpCutout.Height - 1 do begin ImagePixel := PColor32Entry(BmpCutout.ScanLine[Y]); ImagePixel2 := PColor32Entry(Mask.ScanLine[Y]); ImagePixel3 := PColor32Entry(@Bmp32.ScanLine[Y + Bounds.Top][Bounds.Left]); for X := 0 to BmpCutout.Width - 1 do begin if ImagePixel2.A > 0 then ImagePixel3.ARGB := ImagePixel.ARGB; Inc(ImagePixel); Inc(ImagePixel2); Inc(ImagePixel3); end; end; finally Affine.Free; BmpCutout.Free; BmpRotated.Free; Mask.Free; end; end; end. |
Added src/graphics32/GR32_Brushes.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 | unit GR32_Brushes; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Vectorial Polygon Rasterizer for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * * Portions created by the Initial Developer are Copyright (C) 2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Classes, GR32, GR32_Polygons, GR32_Transforms; type TCustomBrush = class; TBrushClass = class of TCustomBrush; // TODO: devise a common base class for TBrushCollection/TLayerCollection { TBrushCollection } TBrushCollection = class(TNotifiablePersistent) private FItems: TList; FOwner: TPersistent; procedure InsertItem(Item: TCustomBrush); procedure RemoveItem(Item: TCustomBrush); function GetCount: Integer; function GetItem(Index: Integer): TCustomBrush; procedure SetItem(Index: Integer; const Value: TCustomBrush); public constructor Create(AOwner: TPersistent); destructor Destroy; override; function Add(ItemClass: TBrushClass): TCustomBrush; procedure Clear; procedure Delete(Index: Integer); function Insert(Index: Integer; ItemClass: TBrushClass): TCustomBrush; property Owner: TPersistent read FOwner; property Count: Integer read GetCount; property Items[Index: Integer]: TCustomBrush read GetItem write SetItem; default; end; { TCustomBrush } TCustomBrush = class(TNotifiablePersistent) private FBrushCollection: TBrushCollection; FVisible: Boolean; function GetIndex: Integer; procedure SetBrushCollection(const Value: TBrushCollection); procedure SetVisible(const Value: Boolean); protected procedure SetIndex(Value: Integer); virtual; procedure UpdateRenderer(Renderer: TCustomPolygonRenderer); virtual; public constructor Create(ABrushCollection: TBrushCollection); virtual; destructor Destroy; override; procedure Changed; override; procedure PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); virtual; procedure PolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); virtual; property Index: Integer read GetIndex write SetIndex; property BrushCollection: TBrushCollection read FBrushCollection write SetBrushCollection; property Visible: Boolean read FVisible write SetVisible; end; { TSolidBrush } TSolidBrush = class(TCustomBrush) private FFillColor: TColor32; FFillMode: TPolyFillMode; FFiller: TCustomPolygonFiller; procedure SetFillColor(const Value: TColor32); procedure SetFillMode(const Value: TPolyFillMode); procedure SetFiller(const Value: TCustomPolygonFiller); protected procedure UpdateRenderer(Renderer: TCustomPolygonRenderer); override; public constructor Create(ABrushCollection: TBrushCollection); override; property FillColor: TColor32 read FFillColor write SetFillColor; property FillMode: TPolyFillMode read FFillMode write SetFillMode; property Filler: TCustomPolygonFiller read FFiller write SetFiller; end; { TNestedBrush } TNestedBrush = class(TSolidBrush) private FBrushes: TBrushCollection; public constructor Create(ABrushCollection: TBrushCollection); override; destructor Destroy; override; procedure PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); override; procedure PolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); override; property Brushes: TBrushCollection read FBrushes; end; { TStrokeBrush } TStrokeBrush = class(TSolidBrush) private FStrokeWidth: TFloat; FJoinStyle: TJoinStyle; FMiterLimit: TFloat; FEndStyle: TEndStyle; procedure SetStrokeWidth(const Value: TFloat); procedure SetEndStyle(const Value: TEndStyle); procedure SetJoinStyle(const Value: TJoinStyle); procedure SetMiterLimit(const Value: TFloat); public constructor Create(BrushCollection: TBrushCollection); override; procedure PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); override; property StrokeWidth: TFloat read FStrokeWidth write SetStrokeWidth; property JoinStyle: TJoinStyle read FJoinStyle write SetJoinStyle; property EndStyle: TEndStyle read FEndStyle write SetEndStyle; property MiterLimit: TFloat read FMiterLimit write SetMiterLimit; end; { TGrowBrush } TGrowBrush = class(TNestedBrush) private FGrowAmount: TFloat; FJoinStyle: TJoinStyle; FMiterLimit: TFloat; procedure SetGrowAmount(const Value: TFloat); procedure SetJoinStyle(const Value: TJoinStyle); procedure SetMiterLimit(const Value: TFloat); public constructor Create(BrushCollection: TBrushCollection); override; procedure PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); override; property GrowAmount: TFloat read FGrowAmount write SetGrowAmount; property JoinStyle: TJoinStyle read FJoinStyle write SetJoinStyle; property MiterLimit: TFloat read FMiterLimit write SetMiterLimit; end; { TDashedBrush } TDashedBrush = class(TStrokeBrush) private FDashOffset: TFloat; FDashArray: TArrayOfFloat; procedure SetDashOffset(const Value: TFloat); public procedure PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); override; procedure SetDashArray(const ADashArray: array of TFloat); property DashOffset: TFloat read FDashOffset write SetDashOffset; end; implementation uses GR32_VectorUtils; { TBrushCollection } function TBrushCollection.Add(ItemClass: TBrushClass): TCustomBrush; begin Result := ItemClass.Create(Self); Result.Index := FItems.Count - 1; //Notify(lnLayerAdded, Result, Result.Index); end; procedure TBrushCollection.Clear; begin BeginUpdate; try while FItems.Count > 0 do TCustomBrush(FItems.Last).Free; //Notify(lnCleared, nil, 0); finally EndUpdate; end; end; constructor TBrushCollection.Create(AOwner: TPersistent); begin FItems := TList.Create; end; procedure TBrushCollection.Delete(Index: Integer); begin TCustomBrush(FItems[Index]).Free; end; destructor TBrushCollection.Destroy; begin if Assigned(FItems) then Clear; FItems.Free; inherited; end; function TBrushCollection.GetCount: Integer; begin Result := FItems.Count; end; function TBrushCollection.GetItem(Index: Integer): TCustomBrush; begin Result := FItems[Index]; end; function TBrushCollection.Insert(Index: Integer; ItemClass: TBrushClass): TCustomBrush; begin BeginUpdate; try Result := Add(ItemClass); Result.Index := Index; //Notify(lnLayerInserted, Result, Index); finally EndUpdate; end; end; procedure TBrushCollection.InsertItem(Item: TCustomBrush); (* var Index: Integer; *) begin BeginUpdate; try {Index := } FItems.Add(Item); Item.FBrushCollection := Self; //Notify(lnLayerAdded, Item, Index); finally EndUpdate; end; end; procedure TBrushCollection.RemoveItem(Item: TCustomBrush); var Index: Integer; begin BeginUpdate; try Index := FItems.IndexOf(Item); if Index >= 0 then begin FItems.Delete(Index); Item.FBrushCollection := nil; //Notify(lnLayerDeleted, Item, Index); end; finally EndUpdate; end; end; procedure TBrushCollection.SetItem(Index: Integer; const Value: TCustomBrush); begin TCollectionItem(FItems[Index]).Assign(Value); end; { TCustomBrush } procedure TCustomBrush.Changed; begin inherited; if Assigned(FBrushCollection) then FBrushCollection.Changed; end; constructor TCustomBrush.Create(ABrushCollection: TBrushCollection); begin BrushCollection := ABrushCollection; FVisible := True; end; destructor TCustomBrush.Destroy; begin SetBrushCollection(nil); inherited; end; function TCustomBrush.GetIndex: Integer; begin if Assigned(FBrushCollection) then Result := FBrushCollection.FItems.IndexOf(Self) else Result := -1; end; procedure TCustomBrush.PolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); begin //PolyPolygonFS(Renderer, PolyPolygon(Points), ClipRect, Transformation, Closed); //Renderer.PolygonFS(Points, ClipRect, Transformation); PolyPolygonFS(Renderer, PolyPolygon(Points), ClipRect, Transformation, Closed); end; procedure TCustomBrush.PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); begin UpdateRenderer(Renderer); Renderer.PolyPolygonFS(Points, ClipRect, Transformation); end; procedure TCustomBrush.SetBrushCollection(const Value: TBrushCollection); begin if FBrushCollection <> Value then begin if Assigned(FBrushCollection) then FBrushCollection.RemoveItem(Self); if Assigned(Value) then Value.InsertItem(Self); end; end; procedure TCustomBrush.SetIndex(Value: Integer); var CurIndex: Integer; begin CurIndex := GetIndex; if (CurIndex >= 0) and (CurIndex <> Value) then with FBrushCollection do begin if Value < 0 then Value := 0; if Value >= Count then Value := Count - 1; if Value <> CurIndex then begin if Visible then BeginUpdate; try FBrushCollection.FItems.Move(CurIndex, Value); finally if Visible then EndUpdate; end; end; end; end; procedure TCustomBrush.SetVisible(const Value: Boolean); begin if FVisible <> Value then begin FVisible := Value; Changed; end; end; procedure TCustomBrush.UpdateRenderer(Renderer: TCustomPolygonRenderer); begin end; { TNestedBrush } constructor TNestedBrush.Create(ABrushCollection: TBrushCollection); begin inherited; FBrushes := TBrushCollection.Create(Self); end; destructor TNestedBrush.Destroy; begin FBrushes.Free; inherited; end; procedure TNestedBrush.PolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); var I: Integer; begin for I := 0 to FBrushes.Count - 1 do if FBrushes[I].Visible then FBrushes[I].PolygonFS(Renderer, Points, ClipRect, Transformation, Closed); end; procedure TNestedBrush.PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); var I: Integer; begin for I := 0 to FBrushes.Count - 1 do if FBrushes[I].Visible then FBrushes[I].PolyPolygonFS(Renderer, Points, ClipRect, Transformation, Closed); end; { TSolidBrush } constructor TSolidBrush.Create(ABrushCollection: TBrushCollection); begin inherited; FFillColor := clBlack32; end; procedure TSolidBrush.SetFillColor(const Value: TColor32); begin if FFillColor <> Value then begin FFillColor := Value; Changed; end; end; procedure TSolidBrush.SetFiller(const Value: TCustomPolygonFiller); begin if FFiller <> Value then begin FFiller := Value; Changed; end; end; procedure TSolidBrush.SetFillMode(const Value: TPolyFillMode); begin if FFillMode <> Value then begin FFillMode := Value; Changed; end; end; procedure TSolidBrush.UpdateRenderer(Renderer: TCustomPolygonRenderer); var R: TPolygonRenderer32; begin R := Renderer as TPolygonRenderer32; R.Color := FillColor; R.FillMode := FillMode; R.Filler := Filler; end; { TStrokeBrush } constructor TStrokeBrush.Create(BrushCollection: TBrushCollection); begin inherited; FStrokeWidth := 1; FMiterLimit := DEFAULT_MITER_LIMIT; end; procedure TStrokeBrush.PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); var APoints: TArrayOfArrayOfFloatPoint; begin APoints := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit); inherited PolyPolygonFS(Renderer, APoints, ClipRect, Transformation, Closed); end; procedure TStrokeBrush.SetEndStyle(const Value: TEndStyle); begin if FEndStyle <> Value then begin FEndStyle := Value; Changed; end; end; procedure TStrokeBrush.SetJoinStyle(const Value: TJoinStyle); begin if FJoinStyle <> Value then begin FJoinStyle := Value; Changed; end; end; procedure TStrokeBrush.SetMiterLimit(const Value: TFloat); begin if FMiterLimit <> Value then begin FMiterLimit := Value; Changed; end; end; procedure TStrokeBrush.SetStrokeWidth(const Value: TFloat); begin if FStrokeWidth <> Value then begin FStrokeWidth := Value; Changed; end; end; { TDashedBrush } procedure TDashedBrush.PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); var I: Integer; begin for I := 0 to High(Points) do inherited PolyPolygonFS( Renderer, BuildDashedLine(Points[I], FDashArray, FDashOffset, Closed), ClipRect, Transformation, False); end; procedure TDashedBrush.SetDashArray(const ADashArray: array of TFloat); var L: Integer; begin L := Length(ADashArray); SetLength(FDashArray, L); Move(ADashArray[0], FDashArray[0], L * SizeOf(TFloat)); Changed; end; procedure TDashedBrush.SetDashOffset(const Value: TFloat); begin if FDashOffset <> Value then begin FDashOffset := Value; Changed; end; end; { TGrowBrush } constructor TGrowBrush.Create(BrushCollection: TBrushCollection); begin inherited; FMiterLimit := DEFAULT_MITER_LIMIT; end; procedure TGrowBrush.PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); var I: Integer; APoints: TArrayOfArrayOfFloatPoint; begin SetLength(APoints, Length(Points)); for I := 0 to High(Points) do APoints[I] := Grow(Points[I], GrowAmount, JoinStyle, Closed, MiterLimit); inherited PolyPolygonFS(Renderer, APoints, ClipRect, Transformation, True); end; procedure TGrowBrush.SetGrowAmount(const Value: TFloat); begin if FGrowAmount <> Value then begin FGrowAmount := Value; Changed; end; end; procedure TGrowBrush.SetJoinStyle(const Value: TJoinStyle); begin if FJoinStyle <> Value then begin FJoinStyle := Value; Changed; end; end; procedure TGrowBrush.SetMiterLimit(const Value: TFloat); begin if FMiterLimit <> Value then begin FMiterLimit := Value; Changed; end; end; end. |
Added src/graphics32/GR32_Clipper.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 | unit GR32_Clipper; (******************************************************************************* * * * Author : Angus Johnson * * Version : 5.1.5 * * Date : 4 May 2013 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2010-2013 * * * * License: * * Use, modification & distribution is subject to Boost Software License Ver 1. * * http://www.boost.org/LICENSE_1_0.txt * * * * Attributions: * * The code in this library is an extension of Bala Vatti's clipping algorithm: * * "A generic solution to polygon clipping" * * Communications of the ACM, Vol 35, Issue 7 (July 1992) PP 56-63. * * http://portal.acm.org/citation.cfm?id=129906 * * * * Computer graphics and geometric modeling: implementation and algorithms * * By Max K. Agoston * * Springer; 1 edition (January 4, 2005) * * http://books.google.com/books?q=vatti+clipping+agoston * * * * See also: * * "Polygon Offsetting by Computing Winding Numbers" * * Paper no. DETC2005-85513 PP. 565-575 * * ASME 2005 International Design Engineering Technical Conferences * * and Computers and Information in Engineering Conference (IDETC/CIE2005) * * September 24-28, 2005 , Long Beach, California, USA * * http://www.me.berkeley.edu/~mcmains/pubs/DAC05OffsetPolygon.pdf * * * *******************************************************************************) interface uses Classes, Math, GR32; type PIntPoint = ^TIntPoint; TIntPoint = record X, Y: Int64; end; TIntRect = record Left, Top, Right, Bottom: Int64; end; TClipType = (ctIntersection, ctUnion, ctDifference, ctXor); TPolyType = (ptSubject, ptClip); // By far the most widely used winding rules for polygon filling are // EvenOdd & NonZero (GDI, GDI+, XLib, OpenGL, Cairo, AGG, Quartz, SVG, Gr32) // Others rules include Positive, Negative and ABS_GTR_EQ_TWO (only in OpenGL) // see http://glprogramming.com/red/chapter11.html // nb: Alternate is the same as EvenOdd and Winding is the same as NonZero. TPolyFillType = (pftEvenOdd, pftNonZero, pftPositive, pftNegative, pftAlternate = 0, pftWinding); // TJoinType - used by InflatePolygons() TJoinType = (jtSquare, jtRound, jtMiter); // used internally ... TEdgeSide = (esLeft, esRight); TIntersectProtect = (ipLeft, ipRight); TIntersectProtects = set of TIntersectProtect; TDirection = (dRightToLeft, dLeftToRight); TPolygon = array of TIntPoint; TPolygons = array of TPolygon; PEdge = ^TEdge; TEdge = record XBot : Int64; // bottom YBot : Int64; XCurr: Int64; // current (ie relative to bottom of current scanbeam) YCurr: Int64; XTop : Int64; // top YTop : Int64; Dx : Double; // the inverse of slope DeltaX: Int64; DeltaY: Int64; PolyType : TPolyType; Side : TEdgeSide; WindDelta: Integer; // 1 or -1 depending on winding direction WindCnt : Integer; WindCnt2 : Integer; // winding count of the opposite PolyType OutIdx : Integer; Next : PEdge; Prev : PEdge; NextInLML: PEdge; PrevInAEL: PEdge; NextInAEL: PEdge; PrevInSEL: PEdge; NextInSEL: PEdge; end; PEdgeArray = ^TEdgeArray; TEdgeArray = array[0.. MaxInt div sizeof(TEdge) -1] of TEdge; PScanbeam = ^TScanbeam; TScanbeam = record Y : Int64; Next: PScanbeam; end; PIntersectNode = ^TIntersectNode; TIntersectNode = record Edge1: PEdge; Edge2: PEdge; Pt : TIntPoint; Next : PIntersectNode; end; PLocalMinima = ^TLocalMinima; TLocalMinima = record Y : Int64; LeftBound : PEdge; RightBound: PEdge; Next : PLocalMinima; end; POutPt = ^TOutPt; POutRec = ^TOutRec; TOutRec = record Idx : Integer; BottomPt : POutPt; IsHole : Boolean; //When single polygons (contours) are contained within other polygons, the //'outer' polygons will be either immediately to the left of or also contain //the sibling polygon immediately to the left of a given polygon. By //storing and later parsing this FirstLeft field, it's easy to group into //ExPolygon structs polygons that contain/own other polygons. //However to potentially confuse this, when an OutRec struct is discarded //(ie whenever a contour is merged with another), FirstLeft is reused //by the 'obsolete' OutRec as a pointer to the new contour owner. This way //it's easy to find the outer contour for any inner contour that's still //pointing to an obsolete OutRec struct. FirstLeft : POutRec; Pts : POutPt; end; TArrayOfOutRec = array of POutRec; TOutPt = record Idx : Integer; Pt : TIntPoint; Next : POutPt; Prev : POutPt; end; PJoinRec = ^TJoinRec; TJoinRec = record Pt1a : TIntPoint; Pt1b : TIntPoint; Poly1Idx : Integer; Pt2a : TIntPoint; Pt2b : TIntPoint; Poly2Idx : Integer; end; PHorzRec = ^THorzRec; THorzRec = record Edge : PEdge; SavedIdx : Integer; Next : PHorzRec; Prev : PHorzRec; end; TClipperBase = class private FEdgeList : TList; FLmList : PLocalMinima; // localMinima list FCurrLm : PLocalMinima; // current localMinima node FUse64BitRange : Boolean; // see LoRange and HiRange consts notes below procedure DisposeLocalMinimaList; protected procedure Reset; virtual; procedure PopLocalMinima; property CurrentLm: PLocalMinima read FCurrLm; public constructor Create; virtual; destructor Destroy; override; function Add(const FxdPts: TArrayOfFixedPoint; PolyType: TPolyType): Boolean; overload; function Add(const FxdPts: TArrayOfArrayOfFixedPoint; PolyType: TPolyType): Boolean; overload; function Add(const FltPts: TArrayOfFloatPoint; PolyType: TPolyType): Boolean; overload; function Add(const FltPts: TArrayOfArrayOfFloatPoint; PolyType: TPolyType): Boolean; overload; procedure Clear; virtual; end; TClipper = class(TClipperBase) private FPolyOutList : TList; FJoinList : TList; FClipType : TClipType; FScanbeam : PScanbeam; // scanbeam list FActiveEdges : PEdge; // active Edge list FSortedEdges : PEdge; // used for temporary sorting FIntersectNodes: PIntersectNode; FClipFillType : TPolyFillType; FSubjFillType : TPolyFillType; FExecuteLocked : Boolean; FHorizJoins : PHorzRec; FReverseOutput : Boolean; FForceSimple : Boolean; procedure DisposeScanbeamList; procedure InsertScanbeam(const Y: Int64); function PopScanbeam: Int64; procedure SetWindingCount(Edge: PEdge); function IsEvenOddFillType(Edge: PEdge): Boolean; function IsEvenOddAltFillType(Edge: PEdge): Boolean; procedure AddEdgeToSEL(Edge: PEdge); procedure CopyAELToSEL; procedure InsertLocalMinimaIntoAEL(const BottomY: Int64); procedure SwapPositionsInAEL(E1, E2: PEdge); procedure SwapPositionsInSEL(E1, E2: PEdge); function IsTopHorz(const XPos: Int64): Boolean; procedure ProcessHorizontal(HorzEdge: PEdge); procedure ProcessHorizontals; procedure AddIntersectNode(E1, E2: PEdge; const Pt: TIntPoint); function ProcessIntersections(const BottomY, TopY: Int64): Boolean; procedure BuildIntersectList(const BottomY, TopY: Int64); procedure ProcessIntersectList; procedure DeleteFromAEL(E: PEdge); procedure DeleteFromSEL(E: PEdge); procedure IntersectEdges(E1,E2: PEdge; const Pt: TIntPoint; protects: TIntersectProtects = []); procedure DoMaxima(E: PEdge; const TopY: Int64); procedure UpdateEdgeIntoAEL(var E: PEdge); function FixupIntersectionOrder: Boolean; procedure SwapIntersectNodes(Int1, Int2: PIntersectNode); procedure ProcessEdgesAtTopOfScanbeam(const TopY: Int64); function IsContributing(Edge: PEdge): Boolean; function CreateOutRec: POutRec; procedure AddOutPt(E: PEdge; const Pt: TIntPoint); procedure AddLocalMaxPoly(E1, E2: PEdge; const Pt: TIntPoint); procedure AddLocalMinPoly(E1, E2: PEdge; const Pt: TIntPoint); function GetOutRec(Idx: integer): POutRec; procedure AppendPolygon(E1, E2: PEdge); procedure DisposePolyPts(PP: POutPt); procedure DisposeAllPolyPts; procedure DisposeOutRec(Index: Integer); procedure DisposeIntersectNodes; function GetResultAsFloatPoints: TArrayOfArrayOfFloatPoint; function GetResultAsFixedPoints: TArrayOfArrayOfFixedPoint; procedure FixupOutPolygon(OutRec: POutRec); procedure SetHoleState(E: PEdge; OutRec: POutRec); procedure AddJoin(E1, E2: PEdge; E1OutIdx: Integer = -1; E2OutIdx: Integer = -1); procedure ClearJoins; procedure AddHorzJoin(E: PEdge; Idx: Integer); procedure ClearHorzJoins; function JoinPoints(JR: PJoinRec; out P1, P2: POutPt): Boolean; procedure FixupJoinRecs(JR: PJoinRec; Pt: POutPt; StartIdx: integer); procedure DoSimplePolygons; procedure JoinCommonEdges; protected procedure Reset; override; function ExecuteInternal: Boolean; virtual; public constructor Create; override; destructor Destroy; override; function Execute(ClipType: TClipType; out Solution: TArrayOfArrayOfFloatPoint; SubjFillType: TPolyFillType = pftEvenOdd; ClipFillType: TPolyFillType = pftEvenOdd): Boolean; overload; function Execute(ClipType: TClipType; out Solution: TArrayOfArrayOfFixedPoint; SubjFillType: TPolyFillType = pftEvenOdd; ClipFillType: TPolyFillType = pftEvenOdd): Boolean; overload; procedure Clear; override; // ReverseSolution: reverses the default orientation property ReverseSolution: Boolean read FReverseOutput write FReverseOutput; property ForceSimple: Boolean read FForceSimple write FForceSimple; end; function Orientation(const Pts: TArrayOfFloatPoint): Boolean; overload; function Area(const Pts: TArrayOfFloatPoint): Double; overload; function ReversePolygon(const Pts: TArrayOfFloatPoint): TArrayOfFloatPoint; function ReversePolygons(const Pts: TArrayOfArrayOfFloatPoint): TArrayOfArrayOfFloatPoint; // InflatePolygons precondition: outer polygons MUST be oriented clockwise, // and inner 'hole' polygons must be oriented counter-clockwise ... function InflatePolygons(const FltPts: TArrayOfArrayOfFloatPoint; const Delta: TFloat; JoinType: TJoinType = jtSquare; Limit: TFloat = 0; AutoFix: Boolean = True): TArrayOfArrayOfFloatPoint; // SimplifyPolygon converts A self-intersecting polygon into A simple polygon. function SimplifyPolygon(const Poly: TArrayOfFloatPoint; FillType: TPolyFillType = pftEvenOdd): TArrayOfArrayOfFloatPoint; function SimplifyPolygons(const Polys: TArrayOfArrayOfFloatPoint; FillType: TPolyFillType = pftEvenOdd): TArrayOfArrayOfFloatPoint; function CleanPolygon(Poly: TArrayOfFloatPoint; Distance: Double = 1.415): TArrayOfFloatPoint; function CleanPolygons(const Polys: TArrayOfArrayOfFloatPoint; Distance: double = 1.415): TArrayOfArrayOfFloatPoint; implementation uses SysUtils, Types, GR32_Math, GR32_Geometry, GR32_VectorUtils; {$IF CompilerVersion >= 20} {$DEFINE INLINING} {$IFEND} type TDoublePoint = record X, Y: Double; end; TArrayOfDoublePoint = array of TDoublePoint; const CHorizontal: Double = -3.4e+38; //The Area function places the most limits on coordinate values // So, to avoid overflow errors, they must not exceed the following values... CLoRange: Int64 = $3FFFFFFF; // 1.0e+9 CHiRange: Int64 = $3FFFFFFFFFFFFFFF; // 4.6e+18 // Also, if all coordinates are within +/-LoRange, then calculations will be // faster. Otherwise using Int128 math will render the library ~10-15% slower. resourcestring rsMissingRightbound = 'InsertLocalMinimaIntoAEL: missing RightBound'; rsDoMaxima = 'DoMaxima error'; rsUpdateEdgeIntoAEL = 'UpdateEdgeIntoAEL error'; rsHorizontal = 'ProcessHorizontal error'; rsInvalidInt = 'Coordinate exceeds range bounds'; rsJoinError = 'Join Output polygons error'; rsIntersect = 'Intersection error'; //------------------------------------------------------------------------------ // Int128 Functions ... //------------------------------------------------------------------------------ const Mask32Bits = $FFFFFFFF; MulExp = 10; MulFrac = 1 shl MulExp; //1 shl 10 = 1024 DivFrac = 1 / MulFrac; ScaleExp = 16 - MulExp; type //nb: TInt128.Lo is typed Int64 instead of UInt64 to provide Delphi 7 //compatability. However while UInt64 isn't a recognised type in //Delphi 7, it can still be used in typecasts. TInt128 = record Hi : Int64; Lo : Int64; end; {$OVERFLOWCHECKS OFF} procedure Int128Negate(var Val: TInt128); {$IFDEF USEINLINING} inline; {$ENDIF} begin if Val.Lo = 0 then begin Val.Hi := -Val.Hi; end else begin Val.Lo := -Val.Lo; Val.Hi := not Val.Hi; end; end; //------------------------------------------------------------------------------ function Int128(const Val: Int64): TInt128; overload; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result.Lo := val; if val < 0 then Result.Hi := -1 else Result.Hi := 0; end; //------------------------------------------------------------------------------ function Int128Equal(const Int1, Int2: TInt128): Boolean; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result := (Int1.Lo = Int2.Lo) and (Int1.Hi = Int2.Hi); end; //------------------------------------------------------------------------------ function Int128LessThan(const Int1, Int2: TInt128): Boolean; {$IFDEF USEINLINING} inline; {$ENDIF} begin if (Int1.Hi <> Int2.Hi) then Result := Int1.Hi < Int2.Hi else Result := UInt64(Int1.Lo) < UInt64(Int2.Lo); end; //--------------------------------------------------------------------------- function Int128Add(const Int1, Int2: TInt128): TInt128; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result.Lo := Int1.Lo + Int2.Lo; Result.Hi := Int1.Hi + Int2.Hi; if UInt64(Result.Lo) < UInt64(Int1.Lo) then inc(Result.Hi); end; //------------------------------------------------------------------------------ function Int128Sub(const Int1, Int2: TInt128): TInt128; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result.Hi := Int1.Hi - Int2.Hi; Result.Lo := Int1.Lo - Int2.Lo; if UInt64(Result.Lo) > UInt64(Int1.Lo) then dec(Result.Hi); end; //------------------------------------------------------------------------------ function Int128Mul(Int1, Int2: Int64): TInt128; var A, B, C: Int64; Int1Hi, Int1Lo, Int2Hi, Int2Lo: Int64; Negate: Boolean; begin // save the Result's sign before clearing both sign bits ... Negate := (Int1 < 0) <> (Int2 < 0); if Int1 < 0 then Int1 := -Int1; if Int2 < 0 then Int2 := -Int2; Int1Hi := Int1 shr 32; Int1Lo := Int1 and Mask32Bits; Int2Hi := Int2 shr 32; Int2Lo := Int2 and Mask32Bits; A := Int1Hi * Int2Hi; B := Int1Lo * Int2Lo; // because the high (sign) bits in both int1Hi & int2Hi have been zeroed, // there's no risk of 64 bit overflow in the following assignment //(ie: $7FFFFFFF*$FFFFFFFF + $7FFFFFFF*$FFFFFFFF < 64bits) C := Int1Hi*Int2Lo + Int2Hi*Int1Lo; // Result = A shl 64 + c shl 32 + B ... Result.Hi := A + (C shr 32); A := C shl 32; Result.Lo := A + B; if UInt64(Result.Lo) < UInt64(A) then inc(Result.Hi); if Negate then Int128Negate(Result); end; //------------------------------------------------------------------------------ function Int128Div(Dividend, Divisor: TInt128{; out Remainder: TInt128}): TInt128; var Cntr: TInt128; Negate: Boolean; begin if (Divisor.Lo = 0) and (Divisor.Hi = 0) then raise Exception.create('int128Div error: divide by zero'); Negate := (Divisor.Hi < 0) <> (Dividend.Hi < 0); if Dividend.Hi < 0 then Int128Negate(Dividend); if Divisor.Hi < 0 then Int128Negate(Divisor); if Int128LessThan(Divisor, Dividend) then begin Result.Hi := 0; Result.Lo := 0; Cntr.Lo := 1; Cntr.Hi := 0; //while (Dividend >= Divisor) do while not Int128LessThan(Dividend, Divisor) do begin //divisor := divisor shl 1; Divisor.Hi := Divisor.Hi shl 1; if Divisor.Lo < 0 then inc(Divisor.Hi); Divisor.Lo := Divisor.Lo shl 1; //Cntr := Cntr shl 1; Cntr.Hi := Cntr.Hi shl 1; if Cntr.Lo < 0 then inc(Cntr.Hi); Cntr.Lo := Cntr.Lo shl 1; end; //Divisor := Divisor shr 1; Divisor.Lo := Divisor.Lo shr 1; if Divisor.Hi and $1 = $1 then Int64Rec(Divisor.Lo).Hi := Cardinal(Int64Rec(Divisor.Lo).Hi) or $80000000; Divisor.Hi := Divisor.Hi shr 1; //Cntr := Cntr shr 1; Cntr.Lo := Cntr.Lo shr 1; if Cntr.Hi and $1 = $1 then Int64Rec(Cntr.Lo).Hi := Cardinal(Int64Rec(Cntr.Lo).Hi) or $80000000; Cntr.Hi := Cntr.Hi shr 1; //while (Cntr > 0) do while not ((Cntr.Hi = 0) and (Cntr.Lo = 0)) do begin //if ( Dividend >= Divisor) then if not Int128LessThan(Dividend, Divisor) then begin //Dividend := Dividend - Divisor; Dividend := Int128Sub(Dividend, Divisor); //result := result or Cntr; result.Hi := result.Hi or Cntr.Hi; result.Lo := result.Lo or Cntr.Lo; end; //Divisor := Divisor shr 1; Divisor.Lo := Divisor.Lo shr 1; if Divisor.Hi and $1 = $1 then Int64Rec(Divisor.Lo).Hi := Cardinal(Int64Rec(Divisor.Lo).Hi) or $80000000; Divisor.Hi := Divisor.Hi shr 1; //Cntr := Cntr shr 1; Cntr.Lo := Cntr.Lo shr 1; if Cntr.Hi and $1 = $1 then Int64Rec(Cntr.Lo).Hi := Cardinal(Int64Rec(Cntr.Lo).Hi) or $80000000; Cntr.Hi := Cntr.Hi shr 1; end; if Negate then Int128Negate(Result); //Remainder := Dividend; end else if (Divisor.Hi = Dividend.Hi) and (Divisor.Lo = Dividend.Lo) then begin Result := Int128(1); end else begin Result := Int128(0); end; end; //------------------------------------------------------------------------------ function Int128AsDouble(val: TInt128): Double; const Shift64: Double = 18446744073709551616.0; var Lo: Int64; begin if (val.Hi < 0) then begin Lo := -val.Lo; if Lo = 0 then Result := val.Hi * Shift64 else Result := -(not val.Hi * Shift64 + UInt64(Lo)); end else Result := val.Hi * Shift64 + UInt64(val.Lo); end; //------------------------------------------------------------------------------ {$OVERFLOWCHECKS ON} //------------------------------------------------------------------------------ // Miscellaneous Functions ... //------------------------------------------------------------------------------ function FullRangeNeeded(const Pts: TPolygon): Boolean; var I: Integer; begin Result := False; for I := 0 to High(Pts) do begin if (Abs(Pts[I].X) > CHiRange) or (Abs(Pts[I].Y) > CHiRange) then raise exception.Create(rsInvalidInt) else if (Abs(Pts[I].X) > CLoRange) or (Abs(Pts[I].Y) > CLoRange) then Result := True; end; end; //------------------------------------------------------------------------------ function PointCount(Pts: POutPt): Integer; var P: POutPt; begin Result := 0; if not Assigned(Pts) then Exit; P := Pts; repeat inc(Result); P := P.Next; until P = Pts; end; //------------------------------------------------------------------------------ function PointsEqual(const P1, P2: TIntPoint): Boolean; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result := (P1.X = P2.X) and (P1.Y = P2.Y); end; //------------------------------------------------------------------------------ function IntPoint(const X, Y: Int64): TIntPoint; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result.X := X; Result.Y := Y; end; //------------------------------------------------------------------------------ function Orientation(const Pts: TArrayOfFloatPoint): Boolean; var I, J, JPlus, JMinus, HighI: Integer; Vec1, Vec2: TFloatPoint; begin Result := True; HighI := High(Pts); if HighI < 2 then Exit; J := 0; for I := 0 to HighI do begin if (Pts[I].Y < Pts[J].Y) then Continue; if ((Pts[I].Y > Pts[J].Y) or (Pts[I].X < Pts[J].X)) then J := I; end; if J = HighI then JPlus := 0 else JPlus := J + 1; if J = 0 then JMinus := HighI else JMinus := J - 1; // get cross product of vectors of edges adjacent the point with largest Y ... Vec1.X := Pts[J].X - Pts[JMinus].X; Vec1.Y := Pts[J].Y - Pts[JMinus].Y; Vec2.X := Pts[JPlus].X - Pts[J].X; Vec2.Y := Pts[JPlus].Y - Pts[J].Y; Result := ((Vec1.X * Vec2.Y) - (Vec2.X * Vec1.Y)) >= 0; end; //------------------------------------------------------------------------------ function Orientation(OutRec: POutRec; UseFullInt64Range: Boolean): Boolean; overload; var Op, OpBottom, OpPrev, OpNext: POutPt; Vec1, Vec2: TIntPoint; Cross: TInt128; begin // first make sure BottomPt is correctly assigned ... OpBottom := OutRec.Pts; Op := OpBottom.Next; while Op <> OutRec.Pts do begin if Op.Pt.Y >= OpBottom.Pt.Y then begin if (Op.Pt.Y > OpBottom.Pt.Y) or (Op.Pt.X < OpBottom.Pt.X) then OpBottom := Op; end; Op := Op.Next; end; OutRec.BottomPt := OpBottom; OpBottom.Idx := OutRec.Idx; Op := OpBottom; // find vertices either Side of BottomPt (skipping duplicate points) .... OpPrev := Op.Prev; while (Op <> OpPrev) and PointsEqual(Op.Pt, OpPrev.Pt) do OpPrev := OpPrev.Prev; OpNext := Op.Next; while (Op <> OpNext) and PointsEqual(Op.Pt, OpNext.Pt) do OpNext := OpNext.Next; Vec1.X := Op.Pt.X - OpPrev.Pt.X; Vec1.Y := Op.Pt.Y - OpPrev.Pt.Y; Vec2.X := OpNext.Pt.X - Op.Pt.X; Vec2.Y := OpNext.Pt.Y - Op.Pt.Y; // perform cross product to determine left or right 'turning' ... if UseFullInt64Range then begin Cross := Int128Sub(Int128Mul(Vec1.X, Vec2.Y), Int128Mul(Vec2.X, Vec1.Y)); Result := Cross.Hi >= 0; end else Result := ((Vec1.X * Vec2.Y) - (Vec2.X * Vec1.Y)) >= 0; end; //------------------------------------------------------------------------------ function Area(const Pts: TArrayOfFloatPoint): Double; overload; var I, HighI: Integer; D: Double; begin Result := 0; HighI := high(Pts); if HighI < 2 then Exit; //see http://www.mathopenref.com/coordpolygonarea2.html D := (Pts[HighI].X + Pts[0].X) * (Pts[0].Y - Pts[HighI].Y); for I := 1 to HighI do D := D + (Pts[I-1].X + Pts[I].X) * (Pts[I].Y - Pts[I-1].Y); Result := D / 2; end; //------------------------------------------------------------------------------ function Area(OutRec: POutRec; UseFullInt64Range: Boolean): Double; overload; var Op: POutPt; D: Double; A: TInt128; begin Op := OutRec.Pts; if not assigned(Op) then begin Result := 0; Exit; end; if UseFullInt64Range then begin A := Int128(0); repeat A := Int128Add(A, Int128Mul(Op.Pt.X + Op.Prev.Pt.X, Op.Prev.Pt.Y - Op.Pt.Y)); Op := Op.Next; until Op = OutRec.Pts; Result := Int128AsDouble(A) / 2; end else begin D := 0; repeat //nb: subtraction reversed since vertices are stored in reverse order ... D := D + (Op.Pt.X + Op.Prev.Pt.X) * (Op.Prev.Pt.Y - Op.Pt.Y); Op := Op.Next; until Op = OutRec.Pts; Result := D / 2; end; end; //------------------------------------------------------------------------------ function ReversePolygon(const Pts: TArrayOfFloatPoint): TArrayOfFloatPoint; var I, HighI: Integer; begin HighI := High(Pts); SetLength(Result, HighI + 1); for I := 0 to HighI do Result[I] := Pts[HighI - I]; end; //------------------------------------------------------------------------------ function ReversePolygons(const Pts: TArrayOfArrayOfFloatPoint): TArrayOfArrayOfFloatPoint; var I, J, highJ: Integer; begin I := Length(Pts); SetLength(Result, I); for I := 0 to I - 1 do begin highJ := High(Pts[I]); SetLength(Result[I], highJ + 1); for J := 0 to highJ do Result[I][J] := Pts[I][highJ - J]; end; end; //------------------------------------------------------------------------------ function PointIsVertex(const Pt: TIntPoint; PP: POutPt): Boolean; var Pp2: POutPt; begin Result := True; Pp2 := PP; repeat if PointsEqual(Pp2.Pt, Pt) then Exit; Pp2 := Pp2.Next; until Pp2 = PP; Result := False; end; //------------------------------------------------------------------------------ function PointOnLineSegment(const Pt, LinePt1, LinePt2: TIntPoint; UseFullInt64Range: Boolean): Boolean; begin if UseFullInt64Range then Result := ((Pt.X = LinePt1.X) and (Pt.Y = LinePt1.Y)) or ((Pt.X = LinePt2.X) and (Pt.Y = LinePt2.Y)) or (((Pt.X > LinePt1.X) = (Pt.X < LinePt2.X)) and ((Pt.Y > LinePt1.Y) = (Pt.Y < LinePt2.Y)) and Int128Equal(Int128Mul((Pt.X - LinePt1.X), (LinePt2.Y - LinePt1.Y)), Int128Mul((LinePt2.X - LinePt1.X), (Pt.Y - LinePt1.Y)))) else Result := ((Pt.X = LinePt1.X) and (Pt.Y = LinePt1.Y)) or ((Pt.X = LinePt2.X) and (Pt.Y = LinePt2.Y)) or (((Pt.X > LinePt1.X) = (Pt.X < LinePt2.X)) and ((Pt.Y > LinePt1.Y) = (Pt.Y < LinePt2.Y)) and ((Pt.X - LinePt1.X) * (LinePt2.Y - LinePt1.Y) = (LinePt2.X - LinePt1.X) * (Pt.Y - LinePt1.Y))); end; //------------------------------------------------------------------------------ function PointOnPolygon(const Pt: TIntPoint; PP: POutPt; UseFullInt64Range: Boolean): Boolean; var Pp2: POutPt; begin Pp2 := PP; repeat if PointOnLineSegment(Pt, Pp2.Pt, Pp2.Next.Pt, UseFullInt64Range) then begin Result := True; Exit; end; Pp2 := Pp2.Next; until (Pp2 = PP); Result := False; end; //------------------------------------------------------------------------------ function PointInPolygon(const Pt: TIntPoint; PP: POutPt; UseFullInt64Range: Boolean): Boolean; var Pp2: POutPt; A, B: TInt128; begin Result := False; Pp2 := PP; if UseFullInt64Range then begin repeat if (((Pp2.Pt.Y <= Pt.Y) and (Pt.Y < Pp2.Prev.Pt.Y)) or ((Pp2.Prev.Pt.Y <= Pt.Y) and (Pt.Y < Pp2.Pt.Y))) then begin A := Int128(Pt.X - Pp2.Pt.X); B := Int128Div( Int128Mul(Pp2.Prev.Pt.X - Pp2.Pt.X, Pt.Y - Pp2.Pt.Y), Int128(Pp2.Prev.Pt.Y - Pp2.Pt.Y) ); if Int128LessThan(A, B) then Result := not Result; end; Pp2 := Pp2.Next; until Pp2 = PP; end else begin repeat if ((((Pp2.Pt.Y <= Pt.Y) and (Pt.Y < Pp2.Prev.Pt.Y)) or ((Pp2.Prev.Pt.Y <= Pt.Y) and (Pt.Y < Pp2.Pt.Y))) and (Pt.X < (Pp2.Prev.Pt.X - Pp2.Pt.X) * (Pt.Y - Pp2.Pt.Y) / (Pp2.Prev.Pt.Y - Pp2.Pt.Y) + Pp2.Pt.X)) then Result := not Result; Pp2 := Pp2.Next; until Pp2 = PP; end; end; //------------------------------------------------------------------------------ function SlopesEqual(E1, E2: PEdge; UseFullInt64Range: Boolean): Boolean; overload; begin if UseFullInt64Range then Result := Int128Equal(Int128Mul(E1.DeltaY, E2.DeltaX), Int128Mul(E1.DeltaX, E2.DeltaY)) else Result := E1.DeltaY * E2.DeltaX = E1.DeltaX * E2.DeltaY; end; //--------------------------------------------------------------------------- function SlopesEqual(const Pt1, Pt2, Pt3: TIntPoint; UseFullInt64Range: Boolean): Boolean; overload; begin if UseFullInt64Range then Result := Int128Equal( Int128Mul(Pt1.Y-Pt2.Y, Pt2.X-Pt3.X), Int128Mul(Pt1.X-Pt2.X, Pt2.Y-Pt3.Y)) else Result := (Pt1.Y-Pt2.Y)*(Pt2.X-Pt3.X) = (Pt1.X-Pt2.X)*(Pt2.Y-Pt3.Y); end; //--------------------------------------------------------------------------- function SlopesEqual(const Pt1, Pt2, Pt3, Pt4: TIntPoint; UseFullInt64Range: Boolean): Boolean; overload; begin if UseFullInt64Range then Result := Int128Equal( Int128Mul(Pt1.Y-Pt2.Y, Pt3.X-Pt4.X), Int128Mul(Pt1.X-Pt2.X, Pt3.Y-Pt4.Y)) else Result := (Pt1.Y-Pt2.Y)*(Pt3.X-Pt4.X) = (Pt1.X-Pt2.X)*(Pt3.Y-Pt4.Y); end; //--------------------------------------------------------------------------- // 0(90º) // // | // // +inf (180º) --- o --- -inf (0º) // function GetDx(const Pt1, Pt2: TIntPoint): Double; {$IFDEF USEINLINING} inline; {$ENDIF} begin if (Pt1.Y = Pt2.Y) then Result := CHorizontal else Result := (Pt2.X - Pt1.X) / (Pt2.Y - Pt1.Y); end; //--------------------------------------------------------------------------- procedure SetDx(E: PEdge); {$IFDEF INLINING} inline; {$ENDIF} begin E.DeltaX := (E.XTop - E.XBot); E.DeltaY := (E.YTop - E.YBot); if E.DeltaY = 0 then E.Dx := CHorizontal else E.Dx := E.DeltaX / E.DeltaY; end; //--------------------------------------------------------------------------- procedure SwapSides(Edge1, Edge2: PEdge); {$IFDEF USEINLINING} inline; {$ENDIF} var Side: TEdgeSide; begin Side := Edge1.Side; Edge1.Side := Edge2.Side; Edge2.Side := Side; end; //------------------------------------------------------------------------------ procedure SwapPolyIndexes(Edge1, Edge2: PEdge); {$IFDEF USEINLINING} inline; {$ENDIF} var OutIdx: Integer; begin OutIdx := Edge1.OutIdx; Edge1.OutIdx := Edge2.OutIdx; Edge2.OutIdx := OutIdx; end; //------------------------------------------------------------------------------ function TopX(Edge: PEdge; const CurrentY: Int64): Int64; overload; begin if CurrentY = Edge.YTop then Result := Edge.XTop else if Edge.XTop = Edge.XBot then Result := Edge.XBot else Result := Edge.XBot + Round(Edge.Dx * (CurrentY - Edge.YBot)); end; //------------------------------------------------------------------------------ function IntersectPoint(Edge1, Edge2: PEdge; out ip: TIntPoint; UseFullInt64Range: Boolean): Boolean; overload; var B1, B2, Y: Double; begin if SlopesEqual(Edge1, Edge2, UseFullInt64Range) then begin //parallel edges, but nevertheless prepare to force the intersection //since Edge2.XCurr < Edge1.XCurr ... if Edge2.YBot > Edge1.YBot then ip.Y := Edge2.YBot else ip.Y := Edge1.YBot; Result := False; Exit; end; if Edge1.Dx = 0 then begin ip.X := Edge1.XBot; if Edge2.Dx = CHorizontal then ip.Y := Edge2.YBot else begin with Edge2^ do B2 := YBot - (XBot/Dx); ip.Y := round(ip.X/Edge2.Dx + B2); end; end else if Edge2.Dx = 0 then begin ip.X := Edge2.XBot; if Edge1.Dx = CHorizontal then ip.Y := Edge1.YBot else begin with Edge1^ do B1 := YBot - (XBot/Dx); ip.Y := round(ip.X/Edge1.Dx + B1); end; end else begin with Edge1^ do B1 := XBot - YBot * Dx; with Edge2^ do B2 := XBot - YBot * Dx; Y := (B2-B1) / (Edge1.Dx - Edge2.Dx); ip.Y := round(Y); if Abs(Edge1.Dx) < Abs(Edge2.Dx) then ip.X := round(Edge1.Dx * Y + B1) else ip.X := round(Edge2.Dx * Y + B2); end; // The precondition - E.XCurr > eNext.XCurr - indicates that the two edges do // intersect below TopY (and hence below the tops of either Edge). However, // when edges are almost parallel, rounding errors may cause False positives - // indicating intersections when there really aren't any. Also, floating point // imprecision can incorrectly place an intersect point beyond/above an Edge. // Therfore, further validation of the IP is warranted ... if (ip.Y < Edge1.YTop) or (ip.Y < Edge2.YTop) then begin // Find the lower top of the two edges and compare X's at this Y. // If Edge1's X is greater than Edge2's X then it's fair to assume an // intersection really has occurred... if (Edge1.YTop > Edge2.YTop) then begin Result := TopX(Edge2, Edge1.YTop) < Edge1.XTop; ip.X := Edge1.XTop; ip.Y := Edge1.YTop; end else begin Result := TopX(Edge1, Edge2.YTop) > Edge2.XTop; ip.X := Edge2.XTop; ip.Y := Edge2.YTop; end; end else Result := True; end; //------------------------------------------------------------------------------ procedure ReversePolyPtLinks(PP: POutPt); var Pp1,Pp2: POutPt; begin Pp1 := PP; repeat Pp2:= Pp1.Next; Pp1.Next := Pp1.Prev; Pp1.Prev := Pp2; Pp1 := Pp2; until Pp1 = PP; end; //------------------------------------------------------------------------------ function FixedPointToIntPoint(const FxPt: TFixedPoint): TIntPoint; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result.X := FxPt.X shr ScaleExp; Result.Y := FxPt.Y shr ScaleExp; end; //------------------------------------------------------------------------------ function IntPointToFixedPoint(const IntPt: TIntPoint): TFixedPoint; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result.X := IntPt.X shl ScaleExp; Result.Y := IntPt.Y shl ScaleExp; end; //------------------------------------------------------------------------------ function FloatPointToIntPoint(const FltPt: TFloatPoint): TIntPoint; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result.X := Round(FltPt.X * MulFrac); Result.Y := Round(FltPt.Y * MulFrac); end; //------------------------------------------------------------------------------ function IntPointToFloatPoint(const IntPt: TIntPoint): TFloatPoint; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result.X := IntPt.X * DivFrac; Result.Y := IntPt.Y * DivFrac; end; //------------------------------------------------------------------------------ // TClipperBase methods ... //------------------------------------------------------------------------------ constructor TClipperBase.Create; begin FEdgeList := TList.Create; FLmList := nil; FCurrLm := nil; FUse64BitRange := False; // ie default is False end; //------------------------------------------------------------------------------ destructor TClipperBase.Destroy; begin Clear; FEdgeList.Free; inherited; end; //------------------------------------------------------------------------------ function TClipperBase.Add(const FltPts: TArrayOfFloatPoint; PolyType: TPolyType): Boolean; //---------------------------------------------------------------------- procedure InitEdge(E, eNext, ePrev: PEdge; const Pt: TIntPoint); begin fillChar(E^, sizeof(TEdge), 0); E.Next := eNext; E.Prev := ePrev; E.XCurr := Pt.X; E.YCurr := Pt.Y; if E.YCurr >= E.Next.YCurr then begin E.XBot := E.XCurr; E.YBot := E.YCurr; E.XTop := E.Next.XCurr; E.YTop := E.Next.YCurr; E.WindDelta := 1; end else begin E.XTop := E.XCurr; E.YTop := E.YCurr; E.XBot := E.Next.XCurr; E.YBot := E.Next.YCurr; E.WindDelta := -1; end; SetDx(E); E.PolyType := PolyType; E.OutIdx := -1; end; //---------------------------------------------------------------------- procedure SwapX(E: PEdge); begin // swap horizontal edges' top and bottom x's so they follow the natural // progression of the bounds - ie so their xbots will align with the // adjoining lower Edge. [Helpful in the ProcessHorizontal() method.] E.XCurr := E.XTop; E.XTop := E.XBot; E.XBot := E.XCurr; end; //---------------------------------------------------------------------- procedure InsertLocalMinima(lm: PLocalMinima); var TmpLm: PLocalMinima; begin if not Assigned(fLmList) then begin FLmList := lm; end else if (lm.Y >= FLmList.Y) then begin lm.Next := FLmList; FLmList := lm; end else begin TmpLm := FLmList; while Assigned(TmpLm.Next) and (lm.Y < TmpLm.Next.Y) do TmpLm := TmpLm.Next; lm.Next := TmpLm.Next; TmpLm.Next := lm; end; end; //---------------------------------------------------------------------- function AddBoundsToLML(E: PEdge): PEdge; var NewLm: PLocalMinima; begin // Starting at the top of one bound we progress to the bottom where there's // A local minima. We then go to the top of the Next bound. These two bounds // form the left and right (or right and left) bounds of the local minima. E.NextInLML := nil; E := E.Next; while True do begin if E.Dx = CHorizontal then begin // nb: proceed through horizontals when approaching from their right, // but break on horizontal minima if approaching from their left. // This ensures 'local minima' are always on the left of horizontals. if (E.Next.YTop < E.YTop) and (E.Next.XBot > E.Prev.XBot) then break; if (E.XTop <> E.Prev.XBot) then SwapX(E); // E.WindDelta := 0; safe option to consider when redesigning E.NextInLML := E.Prev; end else if (E.YBot = E.Prev.YBot) then break else E.NextInLML := E.Prev; E := E.Next; end; // E and E.Prev are now at A local minima ... new(NewLm); NewLm.Y := E.Prev.YBot; NewLm.Next := nil; if E.Dx = CHorizontal then // Horizontal edges never start A left bound begin if (E.XBot <> E.Prev.XBot) then SwapX(E); NewLm.LeftBound := E.Prev; NewLm.RightBound := E; end else if (E.Dx < E.Prev.Dx) then begin NewLm.LeftBound := E.Prev; NewLm.RightBound := E; end else begin NewLm.LeftBound := E; NewLm.RightBound := E.Prev; end; NewLm.LeftBound.Side := esLeft; NewLm.RightBound.Side := esRight; InsertLocalMinima(NewLm); // now process the ascending bound .... while True do begin if (E.Next.YTop = E.YTop) and not (E.Next.Dx = CHorizontal) then break; E.NextInLML := E.Next; E := E.Next; if (E.Dx = CHorizontal) and (E.XBot <> E.Prev.XTop) then SwapX(E); end; Result := E.Next; end; //---------------------------------------------------------------------- var I, J, len: Integer; Edges: PEdgeArray; E, EHighest: PEdge; Pg: TPolygon; MaxVal: Int64; IntPtI: TIntPoint; begin Result := False; // ie assume nothing added len := Length(FltPts); if len < 3 then Exit; SetLength(Pg, len); Pg[0] := FloatPointToIntPoint(FltPts[0]); J := 0; //1. check that coordinate values are within the valid range, and //2. remove duplicate points and co-linear points if FUse64BitRange then MaxVal := CHiRange else MaxVal := CLoRange; for I := 1 to len - 1 do begin IntPtI := FloatPointToIntPoint(FltPts[I]); if ((Abs(FltPts[I].X) > MaxVal) or (Abs(FltPts[I].Y) > MaxVal)) then begin if ((Abs(FltPts[I].X) > CHiRange) or (Abs(FltPts[I].Y) > CHiRange)) then raise exception.Create(rsInvalidInt); MaxVal := CHiRange; FUse64BitRange := True; end; if PointsEqual(Pg[J], IntPtI) then Continue else if (J > 0) and SlopesEqual(Pg[J - 1], Pg[J], IntPtI, FUse64BitRange) then begin if PointsEqual(Pg[J - 1], IntPtI) then Dec(J); end else Inc(J); Pg[J] := IntPtI; end; if (J < 2) then Exit; // now remove duplicate points and co-linear edges at the loop around of the // start and end coordinates ... len := J + 1; while len > 2 do begin // nb: test for point equality before testing slopes ... if PointsEqual(Pg[J], Pg[0]) then Dec(J) else if PointsEqual(Pg[0], Pg[1]) or SlopesEqual(Pg[J], Pg[0], Pg[1], FUse64BitRange) then begin Pg[0] := Pg[J]; Dec(J); end else if SlopesEqual(Pg[J - 1], Pg[J], Pg[0], FUse64BitRange) then Dec(J) else if SlopesEqual(Pg[0], Pg[1], Pg[2], FUse64BitRange) then begin for I := 2 to J do Pg[I - 1] := Pg[I]; Dec(J); end else Break; Dec(len); end; if len < 3 then Exit; Result := True; GetMem(Edges, sizeof(TEdge)*len); FEdgeList.Add(Edges); // convert vertices to A Double-linked-list of edges and initialize ... Edges[0].XCurr := Pg[0].X; Edges[0].YCurr := Pg[0].Y; InitEdge(@Edges[len - 1], @Edges[0], @Edges[len - 2], Pg[len - 1]); for I := len-2 downto 1 do InitEdge(@Edges[I], @Edges[I + 1], @Edges[I - 1], Pg[I]); InitEdge(@Edges[0], @Edges[1], @Edges[len - 1], Pg[0]); // reset XCurr & YCurr and find the 'highest' Edge. (nb: since I'm much more // familiar with positive downwards Y axes, 'highest' here will be the Edge // with the *smallest* YTop.) E := @Edges[0]; EHighest := E; repeat E.XCurr := E.XBot; E.YCurr := E.YBot; if E.YTop < EHighest.YTop then EHighest := E; E := E.Next; until E = @Edges[0]; // make sure eHighest is positioned so the following loop works safely ... if EHighest.WindDelta > 0 then EHighest := EHighest.Next; if (EHighest.Dx = CHorizontal) then EHighest := EHighest.Next; // finally insert each local minima ... E := EHighest; repeat E := AddBoundsToLML(E); until (E = EHighest); end; //------------------------------------------------------------------------------ function TClipperBase.Add(const FltPts: TArrayOfArrayOfFloatPoint; PolyType: TPolyType): Boolean; var I: Integer; begin Result := False; for I := 0 to High(FltPts) do if Add(FltPts[I], PolyType) then Result := True; end; //------------------------------------------------------------------------------ function TClipperBase.Add(const FxdPts: TArrayOfFixedPoint; PolyType: TPolyType): Boolean; begin Result := Add(FixedPointToFloatPoint(FxdPts), PolyType); end; //------------------------------------------------------------------------------ function TClipperBase.Add(const FxdPts: TArrayOfArrayOfFixedPoint; PolyType: TPolyType): Boolean; var I: Integer; begin Result := False; for I := 0 to High(FxdPts) do if Add(FxdPts[I], PolyType) then Result := True; end; //------------------------------------------------------------------------------ procedure TClipperBase.Clear; var I: Integer; begin DisposeLocalMinimaList; for I := 0 to FEdgeList.Count - 1 do dispose(PEdgeArray(fEdgeList[I])); FEdgeList.Clear; FUse64BitRange := False; end; //------------------------------------------------------------------------------ procedure TClipperBase.Reset; var E: PEdge; Lm: PLocalMinima; begin // Reset() allows various clipping operations to be executed // multiple times on the same polygon sets. FCurrLm := FLmList; // reset all edges ... Lm := FCurrLm; while Assigned(Lm) do begin E := Lm.LeftBound; while Assigned(E) do begin E.XCurr := E.XBot; E.YCurr := E.YBot; E.Side := esLeft; E.OutIdx := -1; E := E.NextInLML; end; E := Lm.RightBound; while Assigned(E) do begin E.XCurr := E.XBot; E.YCurr := E.YBot; E.Side := esRight; E.OutIdx := -1; E := E.NextInLML; end; Lm := Lm.Next; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.DisposeLocalMinimaList; begin while Assigned(fLmList) do begin FCurrLm := FLmList.Next; Dispose(fLmList); FLmList := FCurrLm; end; FCurrLm := nil; end; //------------------------------------------------------------------------------ procedure TClipperBase.PopLocalMinima; begin if not Assigned(fCurrLM) then Exit; FCurrLM := FCurrLM.Next; end; //------------------------------------------------------------------------------ // TClipper methods ... //------------------------------------------------------------------------------ constructor TClipper.Create; begin inherited Create; FJoinList := TList.Create; FPolyOutList := TList.Create; end; //------------------------------------------------------------------------------ destructor TClipper.Destroy; begin inherited; // this must be first since inherited Destroy calls Clear. DisposeScanbeamList; FJoinList.Free; FPolyOutList.Free; end; //------------------------------------------------------------------------------ procedure TClipper.Clear; begin DisposeAllPolyPts; inherited; end; //------------------------------------------------------------------------------ procedure TClipper.DisposeScanbeamList; var SB: PScanbeam; begin while Assigned(fScanbeam) do begin SB := FScanbeam.Next; Dispose(fScanbeam); FScanbeam := SB; end; end; //------------------------------------------------------------------------------ procedure TClipper.Reset; var Lm: PLocalMinima; begin inherited Reset; FScanbeam := nil; DisposeAllPolyPts; Lm := FLmList; while Assigned(Lm) do begin InsertScanbeam(Lm.Y); InsertScanbeam(Lm.LeftBound.YTop); Lm := Lm.Next; end; end; //------------------------------------------------------------------------------ function TClipper.Execute(clipType: TClipType; out Solution: TArrayOfArrayOfFloatPoint; SubjFillType: TPolyFillType = pftEvenOdd; ClipFillType: TPolyFillType = pftEvenOdd): Boolean; begin Result := False; Solution := nil; if FExecuteLocked then Exit; try FExecuteLocked := True; FSubjFillType := subjFillType; FClipFillType := clipFillType; FClipType := clipType; Result := ExecuteInternal; if Result then Solution := GetResultAsFloatPoints; finally FExecuteLocked := False; end; end; //------------------------------------------------------------------------------ function TClipper.Execute(clipType: TClipType; out solution: TArrayOfArrayOfFixedPoint; subjFillType: TPolyFillType = pftEvenOdd; clipFillType: TPolyFillType = pftEvenOdd): Boolean; begin Result := False; solution := nil; if FExecuteLocked then Exit; try FExecuteLocked := True; FSubjFillType := subjFillType; FClipFillType := clipFillType; FClipType := clipType; Result := ExecuteInternal; if Result then solution := GetResultAsFixedPoints; finally FExecuteLocked := False; end; end; //------------------------------------------------------------------------------ function PolySort(item1, item2: pointer): Integer; var P1, P2: POutRec; Idx1, Idx2: Integer; begin Result := 0; if item1 = item2 then Exit; P1 := item1; P2 := item2; if not Assigned(P1.Pts) or not Assigned(P2.Pts) then begin if Assigned(P1.Pts) then Result := -1 else if Assigned(P2.Pts) then Result := 1; Exit; end; if P1.IsHole then Idx1 := P1.FirstLeft.Idx else Idx1 := P1.Idx; if P2.IsHole then Idx2 := P2.FirstLeft.Idx else Idx2 := P2.Idx; Result := Idx1 - Idx2; if (Result = 0) and (P1.IsHole <> P2.IsHole) then begin if P1.IsHole then Result := 1 else Result := -1; end; end; //------------------------------------------------------------------------------ function TClipper.ExecuteInternal: Boolean; var I: Integer; OutRec: POutRec; BottomY, TopY: Int64; begin Result := False; try try Reset; if not Assigned(fScanbeam) then begin Result := True; Exit; end; BottomY := PopScanbeam; repeat InsertLocalMinimaIntoAEL(BottomY); ClearHorzJoins; ProcessHorizontals; TopY := PopScanbeam; if not ProcessIntersections(BottomY, TopY) then Exit; ProcessEdgesAtTopOfScanbeam(TopY); BottomY := TopY; until FScanbeam = nil; // tidy up output polygons and fix orientations where necessary ... for I := 0 to FPolyOutList.Count - 1 do begin OutRec := FPolyOutList[I]; if not Assigned(OutRec.Pts) then Continue; FixupOutPolygon(OutRec); if not Assigned(OutRec.Pts) then Continue; if (OutRec.IsHole xor FReverseOutput) = (Area(OutRec, FUse64BitRange) > 0) then ReversePolyPtLinks(OutRec.Pts); end; if FJoinList.count > 0 then JoinCommonEdges; if FForceSimple then DoSimplePolygons; Result := True; except Result := False; end; finally ClearJoins; ClearHorzJoins; end; end; //------------------------------------------------------------------------------ procedure TClipper.InsertScanbeam(const Y: Int64); var Sb, Sb2: PScanbeam; begin new(Sb); Sb.Y := Y; if not Assigned(fScanbeam) then begin FScanbeam := Sb; Sb.Next := nil; end else if Y > FScanbeam.Y then begin Sb.Next := FScanbeam; FScanbeam := Sb; end else begin Sb2 := FScanbeam; while Assigned(Sb2.Next) and (Y <= Sb2.Next.Y) do Sb2 := Sb2.Next; if Y <> Sb2.Y then begin Sb.Next := Sb2.Next; Sb2.Next := Sb; end else dispose(Sb); // ie ignores duplicates end; end; //------------------------------------------------------------------------------ function TClipper.PopScanbeam: Int64; var Sb: PScanbeam; begin Result := FScanbeam.Y; Sb := FScanbeam; FScanbeam := FScanbeam.Next; dispose(Sb); end; //------------------------------------------------------------------------------ procedure TClipper.DisposePolyPts(PP: POutPt); var TmpPp: POutPt; begin PP.Prev.Next := nil; while Assigned(PP) do begin TmpPp := PP; PP := PP.Next; dispose(TmpPp); end; end; //------------------------------------------------------------------------------ procedure TClipper.DisposeAllPolyPts; var I: Integer; begin for I := 0 to FPolyOutList.Count - 1 do DisposeOutRec(I); FPolyOutList.Clear; end; //------------------------------------------------------------------------------ procedure TClipper.DisposeOutRec(Index: Integer); var OutRec: POutRec; begin OutRec := FPolyOutList[Index]; if Assigned(OutRec.Pts) then DisposePolyPts(OutRec.Pts); Dispose(OutRec); FPolyOutList[Index] := nil; end; //------------------------------------------------------------------------------ procedure TClipper.SetWindingCount(Edge: PEdge); var E: PEdge; begin E := Edge.PrevInAEL; // find the Edge of the same PolyType that immediately preceeds 'Edge' in AEL while Assigned(E) and (E.PolyType <> Edge.PolyType) do E := E.PrevInAEL; if not Assigned(E) then begin Edge.WindCnt := Edge.WindDelta; Edge.WindCnt2 := 0; E := FActiveEdges; // ie get ready to calc WindCnt2 end else if IsEvenOddFillType(Edge) then begin // even-odd filling ... Edge.WindCnt := 1; Edge.WindCnt2 := E.WindCnt2; E := E.NextInAEL; // ie get ready to calc WindCnt2 end else begin // NonZero, Positive, or Negative filling ... if E.WindCnt * E.WindDelta < 0 then begin if (Abs(E.WindCnt) > 1) then begin if (E.WindDelta * Edge.WindDelta < 0) then Edge.WindCnt := E.WindCnt else Edge.WindCnt := E.WindCnt + Edge.WindDelta; end else Edge.WindCnt := E.WindCnt + E.WindDelta + Edge.WindDelta; end else begin if (Abs(E.WindCnt) > 1) and (E.WindDelta * Edge.WindDelta < 0) then Edge.WindCnt := E.WindCnt else if E.WindCnt + Edge.WindDelta = 0 then Edge.WindCnt := E.WindCnt else Edge.WindCnt := E.WindCnt + Edge.WindDelta; end; Edge.WindCnt2 := E.WindCnt2; E := E.NextInAEL; // ie get ready to calc WindCnt2 end; // update WindCnt2 ... if IsEvenOddAltFillType(Edge) then begin // even-odd filling ... while (E <> Edge) do begin if Edge.WindCnt2 = 0 then Edge.WindCnt2 := 1 else Edge.WindCnt2 := 0; E := E.NextInAEL; end; end else begin // NonZero, Positive, or Negative filling ... while (E <> Edge) do begin inc(Edge.WindCnt2, E.WindDelta); E := E.NextInAEL; end; end; end; //------------------------------------------------------------------------------ function TClipper.IsEvenOddFillType(Edge: PEdge): Boolean; begin if Edge.PolyType = ptSubject then Result := FSubjFillType = pftEvenOdd else Result := FClipFillType = pftEvenOdd; end; //------------------------------------------------------------------------------ function TClipper.IsEvenOddAltFillType(Edge: PEdge): Boolean; begin if Edge.PolyType = ptSubject then Result := FClipFillType = pftEvenOdd else Result := FSubjFillType = pftEvenOdd; end; //------------------------------------------------------------------------------ function TClipper.IsContributing(Edge: PEdge): Boolean; var Pft, Pft2: TPolyFillType; begin if Edge.PolyType = ptSubject then begin Pft := FSubjFillType; Pft2 := FClipFillType; end else begin Pft := FClipFillType; Pft2 := FSubjFillType end; case Pft of pftEvenOdd, pftNonZero: Result := Abs(Edge.WindCnt) = 1; pftPositive: Result := (Edge.WindCnt = 1); else Result := (Edge.WindCnt = -1); end; if not Result then Exit; case FClipType of ctIntersection: case Pft2 of pftEvenOdd, pftNonZero: Result := (Edge.WindCnt2 <> 0); pftPositive: Result := (Edge.WindCnt2 > 0); pftNegative: Result := (Edge.WindCnt2 < 0); end; ctUnion: case Pft2 of pftEvenOdd, pftNonZero: Result := (Edge.WindCnt2 = 0); pftPositive: Result := (Edge.WindCnt2 <= 0); pftNegative: Result := (Edge.WindCnt2 >= 0); end; ctDifference: if Edge.PolyType = ptSubject then case Pft2 of pftEvenOdd, pftNonZero: Result := (Edge.WindCnt2 = 0); pftPositive: Result := (Edge.WindCnt2 <= 0); pftNegative: Result := (Edge.WindCnt2 >= 0); end else case Pft2 of pftEvenOdd, pftNonZero: Result := (Edge.WindCnt2 <> 0); pftPositive: Result := (Edge.WindCnt2 > 0); pftNegative: Result := (Edge.WindCnt2 < 0); end; end; end; //------------------------------------------------------------------------------ procedure TClipper.AddLocalMinPoly(E1, E2: PEdge; const Pt: TIntPoint); var E, PrevE: PEdge; begin if (E2.Dx = CHorizontal) or (E1.Dx > E2.Dx) then begin AddOutPt(E1, Pt); E2.OutIdx := E1.OutIdx; E1.Side := esLeft; E2.Side := esRight; E := E1; if E.PrevInAEL = E2 then PrevE := E2.PrevInAEL else PrevE := E.PrevInAEL; end else begin AddOutPt(E2, Pt); E1.OutIdx := E2.OutIdx; E1.Side := esRight; E2.Side := esLeft; E := E2; if E.PrevInAEL = E1 then PrevE := E1.PrevInAEL else PrevE := E.PrevInAEL; end; if Assigned(PrevE) and (PrevE.OutIdx >= 0) and (TopX(PrevE, Pt.Y) = TopX(E, Pt.Y)) and SlopesEqual(E, PrevE, FUse64BitRange) then AddJoin(E, PrevE); end; //------------------------------------------------------------------------------ procedure TClipper.AddLocalMaxPoly(E1, E2: PEdge; const Pt: TIntPoint); begin AddOutPt(E1, Pt); if (E1.OutIdx = E2.OutIdx) then begin E1.OutIdx := -1; E2.OutIdx := -1; end else if E1.OutIdx < E2.OutIdx then AppendPolygon(E1, E2) else AppendPolygon(E2, E1); end; //------------------------------------------------------------------------------ procedure TClipper.AddEdgeToSEL(Edge: PEdge); begin // SEL pointers in PEdge are reused to build A list of horizontal edges. // However, we don't need to worry about order with horizontal Edge processing. if not Assigned(fSortedEdges) then begin FSortedEdges := Edge; Edge.PrevInSEL := nil; Edge.NextInSEL := nil; end else begin Edge.NextInSEL := FSortedEdges; Edge.PrevInSEL := nil; FSortedEdges.PrevInSEL := Edge; FSortedEdges := Edge; end; end; //------------------------------------------------------------------------------ procedure TClipper.CopyAELToSEL; var E: PEdge; begin E := FActiveEdges; FSortedEdges := E; while Assigned(E) do begin E.PrevInSEL := E.PrevInAEL; E.NextInSEL := E.NextInAEL; E := E.NextInAEL; end; end; //------------------------------------------------------------------------------ procedure TClipper.AddJoin(E1, E2: PEdge; E1OutIdx: Integer = -1; E2OutIdx: Integer = -1); var Jr: PJoinRec; begin new(Jr); if E1OutIdx >= 0 then Jr.Poly1Idx := E1OutIdx else Jr.Poly1Idx := E1.OutIdx; with E1^ do begin Jr.Pt1a := IntPoint(XCurr, YCurr); Jr.Pt1b := IntPoint(XTop, YTop); end; if E2OutIdx >= 0 then Jr.Poly2Idx := E2OutIdx else Jr.Poly2Idx := E2.OutIdx; with E2^ do begin Jr.Pt2a := IntPoint(XCurr, YCurr); Jr.Pt2b := IntPoint(XTop, YTop); end; FJoinList.add(Jr); end; //------------------------------------------------------------------------------ procedure TClipper.ClearJoins; var I: Integer; begin for I := 0 to FJoinList.Count - 1 do Dispose(PJoinRec(fJoinList[I])); FJoinList.Clear; end; //------------------------------------------------------------------------------ procedure TClipper.AddHorzJoin(E: PEdge; Idx: Integer); var Hr: PHorzRec; begin new(Hr); Hr.Edge := E; Hr.SavedIdx := Idx; if FHorizJoins = nil then begin FHorizJoins := Hr; Hr.Next := Hr; Hr.Prev := Hr; end else begin Hr.Next := FHorizJoins; Hr.Prev := FHorizJoins.Prev; FHorizJoins.Prev.Next := Hr; FHorizJoins.Prev := Hr; end; end; //------------------------------------------------------------------------------ procedure TClipper.ClearHorzJoins; var M, M2: PHorzRec; begin if not Assigned(fHorizJoins) then Exit; M := FHorizJoins; M.Prev.Next := nil; while Assigned(M) do begin M2 := M.Next; dispose(M); M := M2; end; FHorizJoins := nil; end; //------------------------------------------------------------------------------ procedure SwapPoints(var Pt1, Pt2: TIntPoint); var Tmp: TIntPoint; begin Tmp := Pt1; Pt1 := Pt2; Pt2 := Tmp; end; //------------------------------------------------------------------------------ function GetOverlapSegment(Pt1a, Pt1b, Pt2a, Pt2b: TIntPoint; out Pt1, Pt2: TIntPoint): Boolean; begin // precondition: segments are colinear if Abs(Pt1a.X - Pt1b.X) > Abs(Pt1a.Y - Pt1b.Y) then begin if Pt1a.X > Pt1b.X then SwapPoints(Pt1a, Pt1b); if Pt2a.X > Pt2b.X then SwapPoints(Pt2a, Pt2b); if (Pt1a.X > Pt2a.X) then Pt1 := Pt1a else Pt1 := Pt2a; if (Pt1b.X < Pt2b.X) then Pt2 := Pt1b else Pt2 := Pt2b; Result := Pt1.X < Pt2.X; end else begin if Pt1a.Y < Pt1b.Y then SwapPoints(Pt1a, Pt1b); if Pt2a.Y < Pt2b.Y then SwapPoints(Pt2a, Pt2b); if (Pt1a.Y < Pt2a.Y) then Pt1 := Pt1a else Pt1 := Pt2a; if (Pt1b.Y > Pt2b.Y) then Pt2 := Pt1b else Pt2 := Pt2b; Result := Pt1.Y > Pt2.Y; end; end; //------------------------------------------------------------------------------ procedure TClipper.InsertLocalMinimaIntoAEL(const BottomY: Int64); function E2InsertsBeforeE1(E1,E2: PEdge): Boolean; begin if E2.XCurr = E1.XCurr then begin if E2.YTop > E1.YTop then Result := E2.XTop < TopX(E1, E2.YTop) else Result := E1.XTop > TopX(E2, E1.YTop); end else Result := E2.XCurr < E1.XCurr; end; //---------------------------------------------------------------------- procedure InsertEdgeIntoAEL(Edge: PEdge); var E: PEdge; begin Edge.PrevInAEL := nil; Edge.NextInAEL := nil; if not Assigned(fActiveEdges) then begin FActiveEdges := Edge; end else if E2InsertsBeforeE1(fActiveEdges, Edge) then begin Edge.NextInAEL := FActiveEdges; FActiveEdges.PrevInAEL := Edge; FActiveEdges := Edge; end else begin E := FActiveEdges; while Assigned(E.NextInAEL) and not E2InsertsBeforeE1(E.NextInAEL, Edge) do E := E.NextInAEL; Edge.NextInAEL := E.NextInAEL; if Assigned(E.NextInAEL) then E.NextInAEL.PrevInAEL := Edge; Edge.PrevInAEL := E; E.NextInAEL := Edge; end; end; //---------------------------------------------------------------------- var E: PEdge; Pt, Pt2: TIntPoint; Lb, Rb: PEdge; Hj: PHorzRec; begin while Assigned(CurrentLm) and (CurrentLm.Y = BottomY) do begin Lb := CurrentLm.LeftBound; Rb := CurrentLm.RightBound; InsertEdgeIntoAEL(Lb); InsertScanbeam(Lb.YTop); InsertEdgeIntoAEL(Rb); // set Edge winding states ... if IsEvenOddFillType(Lb) then begin Lb.WindDelta := 1; Rb.WindDelta := 1; end else begin Rb.WindDelta := -Lb.WindDelta end; SetWindingCount(Lb); Rb.WindCnt := Lb.WindCnt; Rb.WindCnt2 := Lb.WindCnt2; if Rb.Dx = CHorizontal then begin AddEdgeToSEL(Rb); InsertScanbeam(Rb.NextInLML.YTop); end else InsertScanbeam(Rb.YTop); if IsContributing(Lb) then AddLocalMinPoly(Lb, Rb, IntPoint(Lb.XCurr, CurrentLm.Y)); // if output polygons share an Edge with rb, they'll need joining later ... if (Rb.OutIdx >= 0) and (Rb.Dx = CHorizontal) and Assigned(fHorizJoins) then begin Hj := FHorizJoins; repeat // if horizontals rb & hj.Edge overlap, flag for joining later ... if GetOverlapSegment(IntPoint(Hj.Edge.XBot, Hj.Edge.YBot), IntPoint(Hj.Edge.XTop, Hj.Edge.YTop), IntPoint(Rb.XBot, Rb.YBot), IntPoint(Rb.XTop, Rb.YTop), Pt, Pt2) then AddJoin(Hj.Edge, Rb, Hj.SavedIdx); Hj := Hj.Next; until Hj = FHorizJoins; end; if (Lb.NextInAEL <> Rb) then begin if (Rb.OutIdx >= 0) and (Rb.PrevInAEL.OutIdx >= 0) and SlopesEqual(Rb.PrevInAEL, Rb, FUse64BitRange) then AddJoin(Rb, Rb.PrevInAEL); E := Lb.NextInAEL; Pt := IntPoint(Lb.XCurr,Lb.YCurr); while E <> Rb do begin if not Assigned(E) then raise exception.Create(rsMissingRightbound); // nb: For calculating winding counts etc, IntersectEdges() assumes // that param1 will be to the right of param2 ABOVE the intersection ... IntersectEdges(Rb, E, Pt); E := E.NextInAEL; end; end; PopLocalMinima; end; end; //------------------------------------------------------------------------------ procedure TClipper.DeleteFromAEL(E: PEdge); var AelPrev, AelNext: PEdge; begin AelPrev := E.PrevInAEL; AelNext := E.NextInAEL; if not Assigned(AelPrev) and not Assigned(AelNext) and (E <> FActiveEdges) then Exit; // already deleted if Assigned(AelPrev) then AelPrev.NextInAEL := AelNext else FActiveEdges := AelNext; if Assigned(AelNext) then AelNext.PrevInAEL := AelPrev; E.NextInAEL := nil; E.PrevInAEL := nil; end; //------------------------------------------------------------------------------ procedure TClipper.DeleteFromSEL(E: PEdge); var SelPrev, SelNext: PEdge; begin SelPrev := E.PrevInSEL; SelNext := E.NextInSEL; if not Assigned(SelPrev) and not Assigned(SelNext) and (E <> FSortedEdges) then Exit; // already deleted if Assigned(SelPrev) then SelPrev.NextInSEL := SelNext else FSortedEdges := SelNext; if Assigned(SelNext) then SelNext.PrevInSEL := SelPrev; E.NextInSEL := nil; E.PrevInSEL := nil; end; //------------------------------------------------------------------------------ procedure TClipper.IntersectEdges(E1,E2: PEdge; const Pt: TIntPoint; protects: TIntersectProtects = []); var E1stops, E2stops: Boolean; E1Contributing, E2contributing: Boolean; E1FillType, E2FillType, E1FillType2, E2FillType2: TPolyFillType; E1Wc, E2Wc, E1Wc2, E2Wc2: Integer; begin // E1 will be to the left of E2 BELOW the intersection. Therefore E1 is before // E2 in AEL except when E1 is being inserted at the intersection point ... E1stops := not (ipLeft in protects) and not Assigned(E1.NextInLML) and (E1.XTop = Pt.x) and (E1.YTop = Pt.Y); E2stops := not (ipRight in protects) and not Assigned(E2.NextInLML) and (E2.XTop = Pt.x) and (E2.YTop = Pt.Y); E1Contributing := (E1.OutIdx >= 0); E2contributing := (E2.OutIdx >= 0); // update winding counts... // assumes that E1 will be to the right of E2 ABOVE the intersection if E1.PolyType = E2.PolyType then begin if IsEvenOddFillType(E1) then begin E1Wc := E1.WindCnt; E1.WindCnt := E2.WindCnt; E2.WindCnt := E1Wc; end else begin if E1.WindCnt + E2.WindDelta = 0 then E1.WindCnt := -E1.WindCnt else inc(E1.WindCnt, E2.WindDelta); if E2.WindCnt - E1.WindDelta = 0 then E2.WindCnt := -E2.WindCnt else Dec(E2.WindCnt, E1.WindDelta); end; end else begin if not IsEvenOddFillType(E2) then inc(E1.WindCnt2, E2.WindDelta) else if E1.WindCnt2 = 0 then E1.WindCnt2 := 1 else E1.WindCnt2 := 0; if not IsEvenOddFillType(E1) then Dec(E2.WindCnt2, E1.WindDelta) else if E2.WindCnt2 = 0 then E2.WindCnt2 := 1 else E2.WindCnt2 := 0; end; if E1.PolyType = ptSubject then begin E1FillType := FSubjFillType; E1FillType2 := FClipFillType; end else begin E1FillType := FClipFillType; E1FillType2 := FSubjFillType; end; if E2.PolyType = ptSubject then begin E2FillType := FSubjFillType; E2FillType2 := FClipFillType; end else begin E2FillType := FClipFillType; E2FillType2 := FSubjFillType; end; case E1FillType of pftPositive: E1Wc := E1.WindCnt; pftNegative : E1Wc := -E1.WindCnt; else E1Wc := Abs(E1.WindCnt); end; case E2FillType of pftPositive: E2Wc := E2.WindCnt; pftNegative : E2Wc := -E2.WindCnt; else E2Wc := Abs(E2.WindCnt); end; if E1Contributing and E2contributing then begin if E1stops or E2stops or not (E1Wc in [0,1]) or not (E2Wc in [0,1]) or ((E1.PolyType <> E2.PolyType) and (fClipType <> ctXor)) then AddLocalMaxPoly(E1, E2, Pt) else begin AddOutPt(E1, Pt); AddOutPt(E2, Pt); SwapSides(E1, E2); SwapPolyIndexes(E1, E2); end; end else if E1Contributing then begin if (E2Wc = 0) or (E2Wc = 1) then begin AddOutPt(E1, Pt); SwapSides(E1, E2); SwapPolyIndexes(E1, E2); end; end else if E2contributing then begin if (E1Wc = 0) or (E1Wc = 1) then begin AddOutPt(E2, Pt); SwapSides(E1, E2); SwapPolyIndexes(E1, E2); end; end else if ((E1Wc = 0) or (E1Wc = 1)) and ((E2Wc = 0) or (E2Wc = 1)) and not E1stops and not E2stops then begin // neither Edge is currently contributing ... case E1FillType2 of pftPositive: E1Wc2 := E1.WindCnt2; pftNegative : E1Wc2 := -E1.WindCnt2; else E1Wc2 := Abs(E1.WindCnt2); end; case E2FillType2 of pftPositive: E2Wc2 := E2.WindCnt2; pftNegative : E2Wc2 := -E2.WindCnt2; else E2Wc2 := Abs(E2.WindCnt2); end; if (E1.PolyType <> E2.PolyType) then AddLocalMinPoly(E1, E2, Pt) else if (E1Wc = 1) and (E2Wc = 1) then case FClipType of ctIntersection: if (E1Wc2 > 0) and (E2Wc2 > 0) then AddLocalMinPoly(E1, E2, Pt); ctUnion: if (E1Wc2 <= 0) and (E2Wc2 <= 0) then AddLocalMinPoly(E1, E2, Pt); ctDifference: if ((E1.PolyType = ptClip) and (E1Wc2 > 0) and (E2Wc2 > 0)) or ((E1.PolyType = ptSubject) and (E1Wc2 <= 0) and (E2Wc2 <= 0)) then AddLocalMinPoly(E1, E2, Pt); ctXor: AddLocalMinPoly(E1, E2, Pt); end else swapsides(E1,E2); end; if (E1stops <> E2stops) and ((E1stops and (E1.OutIdx >= 0)) or (E2stops and (E2.OutIdx >= 0))) then begin swapsides(E1,E2); SwapPolyIndexes(E1, E2); end; // finally, delete any non-contributing maxima edges ... if E1stops then deleteFromAEL(E1); if E2stops then deleteFromAEL(E2); end; //------------------------------------------------------------------------------ function FirstParamIsBottomPt(btmPt1, btmPt2: POutPt): Boolean; var Dx1n, Dx1p, Dx2n, Dx2p: Double; P: POutPt; begin //Precondition: bottom-points share the same vertex. //Use inverse slopes of adjacent edges (ie dx/dy) to determine the outer //polygon and hence the 'real' bottompoint. //nb: Slope is vertical when dx == 0. If the greater abs(dx) of param1 //is greater than or equal both abs(dx) in param2 then param1 is outer. P := btmPt1.Prev; while PointsEqual(P.Pt, btmPt1.Pt) and (P <> btmPt1) do P := P.Prev; Dx1p := Abs(GetDx(btmPt1.Pt, P.Pt)); P := btmPt1.Next; while PointsEqual(P.Pt, btmPt1.Pt) and (P <> btmPt1) do P := P.Next; Dx1n := Abs(GetDx(btmPt1.Pt, P.Pt)); P := btmPt2.Prev; while PointsEqual(P.Pt, btmPt2.Pt) and (P <> btmPt2) do P := P.Prev; Dx2p := Abs(GetDx(btmPt2.Pt, P.Pt)); P := btmPt2.Next; while PointsEqual(P.Pt, btmPt2.Pt) and (P <> btmPt2) do P := P.Next; Dx2n := Abs(GetDx(btmPt2.Pt, P.Pt)); Result := ((Dx1p >= Dx2p) and (Dx1p >= Dx2n)) or ((Dx1n >= Dx2p) and (Dx1n >= Dx2n)); end; //------------------------------------------------------------------------------ function GetBottomPt(PP: POutPt): POutPt; var P, Dups: POutPt; begin Dups := nil; P := PP.Next; while P <> PP do begin if P.Pt.Y > PP.Pt.Y then begin PP := P; Dups := nil; end else if (P.Pt.Y = PP.Pt.Y) and (P.Pt.X <= PP.Pt.X) then begin if (P.Pt.X < PP.Pt.X) then begin Dups := nil; PP := P; end else begin if (P.Next <> PP) and (P.Prev <> PP) then Dups := P; end; end; P := P.Next; end; if Assigned(Dups) then begin // there appears to be at least 2 vertices at BottomPt so ... while Dups <> P do begin if not FirstParamIsBottomPt(P, Dups) then PP := Dups; Dups := Dups.Next; while not PointsEqual(Dups.Pt, PP.Pt) do Dups := Dups.Next; end; end; Result := PP; end; //------------------------------------------------------------------------------ procedure TClipper.SetHoleState(E: PEdge; OutRec: POutRec); var E2: PEdge; IsHole: Boolean; begin IsHole := False; E2 := E.PrevInAEL; while Assigned(E2) do begin if (E2.OutIdx >= 0) then begin IsHole := not IsHole; if not Assigned(OutRec.FirstLeft) then OutRec.FirstLeft := POutRec(fPolyOutList[E2.OutIdx]); end; E2 := E2.PrevInAEL; end; if IsHole then OutRec.IsHole := True; end; //------------------------------------------------------------------------------ function GetLowermostRec(OutRec1, OutRec2: POutRec): POutRec; var OutPt1, OutPt2: POutPt; begin if not assigned(OutRec1.BottomPt) then OutRec1.BottomPt := GetBottomPt(OutRec1.Pts); if not assigned(OutRec2.BottomPt) then OutRec2.BottomPt := GetBottomPt(OutRec2.Pts); OutPt1 := OutRec1.BottomPt; OutPt2 := OutRec2.BottomPt; if (OutPt1.Pt.Y > OutPt2.Pt.Y) then Result := OutRec1 else if (OutPt1.Pt.Y < OutPt2.Pt.Y) then Result := OutRec2 else if (OutPt1.Pt.X < OutPt2.Pt.X) then Result := OutRec1 else if (OutPt1.Pt.X > OutPt2.Pt.X) then Result := OutRec2 else if (OutPt1.Next = OutPt1) then Result := OutRec2 else if (OutPt2.Next = OutPt2) then Result := OutRec1 else if FirstParamIsBottomPt(OutPt1, OutPt2) then Result := OutRec1 else Result := OutRec2; end; //------------------------------------------------------------------------------ function Param1RightOfParam2(OutRec1, OutRec2: POutRec): Boolean; begin Result := True; repeat OutRec1 := OutRec1.FirstLeft; if OutRec1 = OutRec2 then Exit; until not Assigned(OutRec1); Result := False; end; //------------------------------------------------------------------------------ function TClipper.GetOutRec(Idx: integer): POutRec; begin Result := FPolyOutList[Idx]; while Result <> FPolyOutList[Result.Idx] do Result := FPolyOutList[Result.Idx]; end; //------------------------------------------------------------------------------ procedure TClipper.AppendPolygon(E1, E2: PEdge); var HoleStateRec, OutRec1, OutRec2: POutRec; P1_lft, P1_rt, P2_lft, P2_rt: POutPt; NewSide: TEdgeSide; OKIdx, ObsoleteIdx: Integer; E: PEdge; begin OutRec1 := FPolyOutList[E1.OutIdx]; OutRec2 := FPolyOutList[E2.OutIdx]; //First work out which polygon fragment has the correct hole state. //Since we're working from the bottom upward and left to right, the left most //and lowermost polygon is outermost and must have the correct hole state ... if Param1RightOfParam2(OutRec1, OutRec2) then HoleStateRec := OutRec2 else if Param1RightOfParam2(OutRec2, OutRec1) then HoleStateRec := OutRec1 else HoleStateRec := GetLowermostRec(OutRec1, OutRec2); // get the start and ends of both output polygons ... P1_lft := OutRec1.Pts; P2_lft := OutRec2.Pts; P1_rt := P1_lft.Prev; P2_rt := P2_lft.Prev; // join E2 poly onto E1 poly and delete pointers to E2 ... if E1.Side = esLeft then begin if E2.Side = esLeft then begin // z y x a b c ReversePolyPtLinks(P2_lft); P2_lft.Next := P1_lft; P1_lft.Prev := P2_lft; P1_rt.Next := P2_rt; P2_rt.Prev := P1_rt; OutRec1.Pts := P2_rt; end else begin // x y z a b c P2_rt.Next := P1_lft; P1_lft.Prev := P2_rt; P2_lft.Prev := P1_rt; P1_rt.Next := P2_lft; OutRec1.Pts := P2_lft; end; NewSide := esLeft; end else begin if E2.Side = esRight then begin // a b c z y x ReversePolyPtLinks(P2_lft); P1_rt.Next := P2_rt; P2_rt.Prev := P1_rt; P2_lft.Next := P1_lft; P1_lft.Prev := P2_lft; end else begin // a b c x y z P1_rt.Next := P2_lft; P2_lft.Prev := P1_rt; P1_lft.Prev := P2_rt; P2_rt.Next := P1_lft; end; NewSide := esRight; end; OutRec1.BottomPt := nil; if HoleStateRec = OutRec2 then begin if OutRec2.FirstLeft <> OutRec1 then OutRec1.FirstLeft := OutRec2.FirstLeft; OutRec1.IsHole := OutRec2.IsHole; end; OutRec2.Pts := nil; OutRec2.BottomPt := nil; OutRec2.FirstLeft := OutRec1; OKIdx := OutRec1.Idx; ObsoleteIdx := OutRec2.Idx; E1.OutIdx := -1; // nb: safe because we only get here via AddLocalMaxPoly E2.OutIdx := -1; E := FActiveEdges; while Assigned(E) do begin if (E.OutIdx = ObsoleteIdx) then begin E.OutIdx := OKIdx; E.Side := NewSide; break; end; E := E.NextInAEL; end; OutRec2.Idx := OutRec1.Idx; end; //------------------------------------------------------------------------------ function TClipper.CreateOutRec: POutRec; begin new(Result); Result.IsHole := False; Result.FirstLeft := nil; Result.Pts := nil; Result.BottomPt := nil; Result.Idx := FPolyOutList.Add(Result); end; //------------------------------------------------------------------------------ procedure TClipper.AddOutPt(E: PEdge; const Pt: TIntPoint); var OutRec: POutRec; Op, Op2: POutPt; ToFront: Boolean; begin ToFront := E.Side = esLeft; if E.OutIdx < 0 then begin OutRec := CreateOutRec; E.OutIdx := OutRec.Idx; new(Op); OutRec.Pts := Op; Op.Pt := Pt; Op.Next := Op; Op.Prev := Op; Op.Idx := OutRec.Idx; SetHoleState(E, OutRec); end else begin OutRec := FPolyOutList[E.OutIdx]; Op := OutRec.Pts; if (ToFront and PointsEqual(Pt, Op.Pt)) or (not ToFront and PointsEqual(Pt, Op.Prev.Pt)) then Exit; new(Op2); Op2.Pt := Pt; Op2.Idx := OutRec.Idx; Op2.Next := Op; Op2.Prev := Op.Prev; Op.Prev.Next := Op2; Op.Prev := Op2; if ToFront then OutRec.Pts := Op2; end; end; //------------------------------------------------------------------------------ procedure TClipper.ProcessHorizontals; var E: PEdge; begin while Assigned(fSortedEdges) do begin E := FSortedEdges; DeleteFromSEL(E); ProcessHorizontal(E); end; end; //------------------------------------------------------------------------------ function TClipper.IsTopHorz(const XPos: Int64): Boolean; var E: PEdge; begin Result := False; E := FSortedEdges; while Assigned(E) do begin if (XPos >= min(E.XCurr,E.XTop)) and (XPos <= max(E.XCurr,E.XTop)) then Exit; E := E.NextInSEL; end; Result := True; end; //------------------------------------------------------------------------------ function IsMinima(E: PEdge): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := Assigned(E) and (E.Prev.NextInLML <> E) and (E.Next.NextInLML <> E); end; //------------------------------------------------------------------------------ function IsMaxima(E: PEdge; const Y: Int64): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := Assigned(E) and (E.YTop = Y) and not Assigned(E.NextInLML); end; //------------------------------------------------------------------------------ function IsIntermediate(E: PEdge; const Y: Int64): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := (E.YTop = Y) and Assigned(E.NextInLML); end; //------------------------------------------------------------------------------ function GetMaximaPair(E: PEdge): PEdge; begin Result := E.Next; if not IsMaxima(Result, E.YTop) or (Result.XTop <> E.XTop) then Result := E.Prev; end; //------------------------------------------------------------------------------ procedure TClipper.SwapPositionsInAEL(E1, E2: PEdge); var Prev,Next: PEdge; begin if E1.NextInAEL = E2 then begin Next := E2.NextInAEL; if Assigned(Next) then Next.PrevInAEL := E1; Prev := E1.PrevInAEL; if Assigned(Prev) then Prev.NextInAEL := E2; E2.PrevInAEL := Prev; E2.NextInAEL := E1; E1.PrevInAEL := E2; E1.NextInAEL := Next; end else if E2.NextInAEL = E1 then begin Next := E1.NextInAEL; if Assigned(Next) then Next.PrevInAEL := E2; Prev := E2.PrevInAEL; if Assigned(Prev) then Prev.NextInAEL := E1; E1.PrevInAEL := Prev; E1.NextInAEL := E2; E2.PrevInAEL := E1; E2.NextInAEL := Next; end else begin Next := E1.NextInAEL; Prev := E1.PrevInAEL; E1.NextInAEL := E2.NextInAEL; if Assigned(E1.NextInAEL) then E1.NextInAEL.PrevInAEL := E1; E1.PrevInAEL := E2.PrevInAEL; if Assigned(E1.PrevInAEL) then E1.PrevInAEL.NextInAEL := E1; E2.NextInAEL := Next; if Assigned(E2.NextInAEL) then E2.NextInAEL.PrevInAEL := E2; E2.PrevInAEL := Prev; if Assigned(E2.PrevInAEL) then E2.PrevInAEL.NextInAEL := E2; end; if not Assigned(E1.PrevInAEL) then FActiveEdges := E1 else if not Assigned(E2.PrevInAEL) then FActiveEdges := E2; end; //------------------------------------------------------------------------------ procedure TClipper.SwapPositionsInSEL(E1, E2: PEdge); var Prev,Next: PEdge; begin if E1.NextInSEL = E2 then begin Next := E2.NextInSEL; if Assigned(Next) then Next.PrevInSEL := E1; Prev := E1.PrevInSEL; if Assigned(Prev) then Prev.NextInSEL := E2; E2.PrevInSEL := Prev; E2.NextInSEL := E1; E1.PrevInSEL := E2; E1.NextInSEL := Next; end else if E2.NextInSEL = E1 then begin Next := E1.NextInSEL; if Assigned(Next) then Next.PrevInSEL := E2; Prev := E2.PrevInSEL; if Assigned(Prev) then Prev.NextInSEL := E1; E1.PrevInSEL := Prev; E1.NextInSEL := E2; E2.PrevInSEL := E1; E2.NextInSEL := Next; end else begin Next := E1.NextInSEL; Prev := E1.PrevInSEL; E1.NextInSEL := E2.NextInSEL; if Assigned(E1.NextInSEL) then E1.NextInSEL.PrevInSEL := E1; E1.PrevInSEL := E2.PrevInSEL; if Assigned(E1.PrevInSEL) then E1.PrevInSEL.NextInSEL := E1; E2.NextInSEL := Next; if Assigned(E2.NextInSEL) then E2.NextInSEL.PrevInSEL := E2; E2.PrevInSEL := Prev; if Assigned(E2.PrevInSEL) then E2.PrevInSEL.NextInSEL := E2; end; if not Assigned(E1.PrevInSEL) then FSortedEdges := E1 else if not Assigned(E2.PrevInSEL) then FSortedEdges := E2; end; //------------------------------------------------------------------------------ procedure TClipper.ProcessHorizontal(HorzEdge: PEdge); function GetNextInAEL(E: PEdge; Direction: TDirection): PEdge; begin if Direction = dLeftToRight then Result := E.NextInAEL else Result := E.PrevInAEL; end; //------------------------------------------------------------------------ var E, eNext, eMaxPair: PEdge; HorzLeft, HorzRight: Int64; Direction: TDirection; const ProtectLeft: array[Boolean] of TIntersectProtects = ([ipRight], [ipLeft,ipRight]); ProtectRight: array[Boolean] of TIntersectProtects = ([ipLeft], [ipLeft,ipRight]); begin (******************************************************************************* * Notes: Horizontal edges (HEs) at scanline intersections (ie at the top or * * bottom of A scanbeam) are processed as if layered. The order in which HEs * * are processed doesn't matter. HEs intersect with other HE xbots only [#], * * and with other non-horizontal edges [*]. Once these intersections are * * processed, intermediate HEs then 'promote' the Edge above (NextInLML) into * * the AEL. These 'promoted' edges may in turn intersect [%] with other HEs. * *******************************************************************************) (******************************************************************************* * \ nb: HE processing order doesn't matter / / * * \ / / * * { -------- \ ------------------- / \ - (3) o==========%==========o - } * * { o==========o (2) / \ . . } * * { . / \ . . } * * { ---- o===============#========*========*=====#==========o (1) ------- } * * / \ / \ / * *******************************************************************************) if HorzEdge.XCurr < HorzEdge.XTop then begin HorzLeft := HorzEdge.XCurr; HorzRight := HorzEdge.XTop; Direction := dLeftToRight; end else begin HorzLeft := HorzEdge.XTop; HorzRight := HorzEdge.XCurr; Direction := dRightToLeft; end; if Assigned(HorzEdge.NextInLML) then eMaxPair := nil else eMaxPair := GetMaximaPair(HorzEdge); E := GetNextInAEL(HorzEdge, Direction); while Assigned(E) do begin if (E.XCurr = HorzEdge.XTop) and not Assigned(eMaxPair) then begin if SlopesEqual(E, HorzEdge.NextInLML, FUse64BitRange) then begin // if output polygons share an Edge, they'll need joining later ... if (HorzEdge.OutIdx >= 0) and (E.OutIdx >= 0) then AddJoin(HorzEdge.NextInLML, E, HorzEdge.OutIdx); break; // we've reached the end of the horizontal line end else if (E.Dx < HorzEdge.NextInLML.Dx) then // we really have got to the end of the intermediate horz Edge so quit. // nb: More -ve slopes follow more +ve slopes ABOVE the horizontal. break; end; eNext := GetNextInAEL(E, Direction); if Assigned(eMaxPair) or ((Direction = dLeftToRight) and (E.XCurr < HorzRight)) or ((Direction = dRightToLeft) and (E.XCurr > HorzLeft)) then begin // so far we're still in range of the horizontal Edge if (E = eMaxPair) then begin // HorzEdge is evidently A maxima horizontal and we've arrived at its end. if Direction = dLeftToRight then IntersectEdges(HorzEdge, E, IntPoint(E.XCurr, HorzEdge.YCurr)) else IntersectEdges(E, HorzEdge, IntPoint(E.XCurr, HorzEdge.YCurr)); if (eMaxPair.OutIdx >= 0) then raise exception.Create(rsHorizontal); Exit; end else if (E.Dx = CHorizontal) and not IsMinima(E) and not (E.XCurr > E.XTop) then begin // An overlapping horizontal Edge. Overlapping horizontal edges are // processed as if layered with the current horizontal Edge (horizEdge) // being infinitesimally lower that the Next (E). Therfore, we // intersect with E only if E.XCurr is within the bounds of HorzEdge ... if Direction = dLeftToRight then IntersectEdges(HorzEdge, E, IntPoint(E.XCurr, HorzEdge.YCurr), ProtectRight[not IsTopHorz(E.XCurr)]) else IntersectEdges(E, HorzEdge, IntPoint(E.XCurr, HorzEdge.YCurr), ProtectLeft[not IsTopHorz(E.XCurr)]); end else if (Direction = dLeftToRight) then IntersectEdges(HorzEdge, E, IntPoint(E.XCurr, HorzEdge.YCurr), ProtectRight[not IsTopHorz(E.XCurr)]) else IntersectEdges(E, HorzEdge, IntPoint(E.XCurr, HorzEdge.YCurr), ProtectLeft[not IsTopHorz(E.XCurr)]); SwapPositionsInAEL(HorzEdge, E); end else if ((Direction = dLeftToRight) and (E.XCurr >= HorzRight)) or ((Direction = dRightToLeft) and (E.XCurr <= HorzLeft)) then Break; E := eNext; end; if Assigned(HorzEdge.NextInLML) then begin if (HorzEdge.OutIdx >= 0) then AddOutPt(HorzEdge, IntPoint(HorzEdge.XTop, HorzEdge.YTop)); UpdateEdgeIntoAEL(HorzEdge); end else begin if HorzEdge.OutIdx >= 0 then IntersectEdges(HorzEdge, eMaxPair, IntPoint(HorzEdge.XTop, HorzEdge.YCurr), [ipLeft,ipRight]); if eMaxPair.OutIdx >= 0 then raise exception.Create(rsHorizontal); DeleteFromAEL(eMaxPair); DeleteFromAEL(HorzEdge); end; end; //------------------------------------------------------------------------------ procedure TClipper.UpdateEdgeIntoAEL(var E: PEdge); var AelPrev, AelNext: PEdge; begin if not Assigned(E.NextInLML) then raise exception.Create(rsUpdateEdgeIntoAEL); AelPrev := E.PrevInAEL; AelNext := E.NextInAEL; E.NextInLML.OutIdx := E.OutIdx; if Assigned(AelPrev) then AelPrev.NextInAEL := E.NextInLML else FActiveEdges := E.NextInLML; if Assigned(AelNext) then AelNext.PrevInAEL := E.NextInLML; E.NextInLML.Side := E.Side; E.NextInLML.WindDelta := E.WindDelta; E.NextInLML.WindCnt := E.WindCnt; E.NextInLML.WindCnt2 := E.WindCnt2; E := E.NextInLML; E.PrevInAEL := AelPrev; E.NextInAEL := AelNext; if E.Dx <> CHorizontal then InsertScanbeam(E.YTop); end; //------------------------------------------------------------------------------ function TClipper.ProcessIntersections(const BottomY, TopY: Int64): Boolean; begin Result := True; try BuildIntersectList(BottomY, TopY); if (FIntersectNodes = nil) then Exit; if (FIntersectNodes.Next = nil) or FixupIntersectionOrder then ProcessIntersectList else Result := False; finally DisposeIntersectNodes; //clean up if there's been an error FSortedEdges := nil; end; end; //------------------------------------------------------------------------------ procedure TClipper.DisposeIntersectNodes; var N: PIntersectNode; begin while Assigned(fIntersectNodes) do begin N := FIntersectNodes.Next; dispose(fIntersectNodes); FIntersectNodes := N; end; end; //------------------------------------------------------------------------------ procedure TClipper.BuildIntersectList(const BottomY, TopY: Int64); var E, eNext: PEdge; Pt: TIntPoint; IsModified: Boolean; begin if not Assigned(fActiveEdges) then Exit; //prepare for sorting ... E := FActiveEdges; FSortedEdges := E; while assigned(E) do begin E.PrevInSEL := E.PrevInAEL; E.NextInSEL := E.NextInAEL; E.XCurr := TopX(E, TopY); E := E.NextInAEL; end; try // bubblesort ... IsModified := True; while IsModified and Assigned(fSortedEdges) do begin IsModified := False; E := FSortedEdges; while Assigned(E.NextInSEL) do begin eNext := E.NextInSEL; if (E.XCurr > eNext.XCurr) then begin if not IntersectPoint(E, eNext, Pt, FUse64BitRange) and (E.XCurr > eNext.XCurr +1) then raise Exception.Create(rsIntersect); if Pt.Y > BottomY then begin Pt.Y := BottomY; Pt.X := TopX(E, Pt.Y); end; AddIntersectNode(E, eNext, Pt); SwapPositionsInSEL(E, eNext); IsModified := True; end else E := eNext; end; if Assigned(E.PrevInSEL) then E.PrevInSEL.NextInSEL := nil else break; end; finally FSortedEdges := nil; end; end; //------------------------------------------------------------------------------ procedure TClipper.AddIntersectNode(E1, E2: PEdge; const Pt: TIntPoint); var Node, NewNode: PIntersectNode; begin new(NewNode); NewNode.Edge1 := E1; NewNode.Edge2 := E2; NewNode.Pt := Pt; NewNode.Next := nil; if not Assigned(fIntersectNodes) then FIntersectNodes := NewNode else if NewNode.Pt.Y > FIntersectNodes.Pt.Y then begin NewNode.Next := FIntersectNodes; FIntersectNodes := NewNode; end else begin Node := FIntersectNodes; while Assigned(Node.Next) and (NewNode.Pt.Y <= Node.Next.Pt.Y) do Node := Node.Next; NewNode.Next := Node.Next; Node.Next := NewNode; end; end; //------------------------------------------------------------------------------ procedure TClipper.ProcessIntersectList; var Node: PIntersectNode; begin while Assigned(fIntersectNodes) do begin Node := FIntersectNodes.Next; with FIntersectNodes^ do begin IntersectEdges(Edge1, Edge2, Pt, [ipLeft,ipRight]); SwapPositionsInAEL(Edge1, Edge2); end; dispose(fIntersectNodes); FIntersectNodes := Node; end; end; //------------------------------------------------------------------------------ procedure TClipper.DoMaxima(E: PEdge; const TopY: Int64); var ENext, EMaxPair: PEdge; X: Int64; begin EMaxPair := GetMaximaPair(E); X := E.XTop; ENext := E.NextInAEL; while ENext <> EMaxPair do begin if not Assigned(ENext) then raise exception.Create(rsDoMaxima); IntersectEdges(E, ENext, IntPoint(X, TopY), [ipLeft, ipRight]); SwapPositionsInAEL(E, ENext); ENext := E.NextInAEL; end; if (E.OutIdx < 0) and (EMaxPair.OutIdx < 0) then begin DeleteFromAEL(E); DeleteFromAEL(EMaxPair); end else if (E.OutIdx >= 0) and (EMaxPair.OutIdx >= 0) then begin IntersectEdges(E, EMaxPair, IntPoint(X, TopY)); end else raise exception.Create(rsDoMaxima); end; //------------------------------------------------------------------------------ procedure TClipper.ProcessEdgesAtTopOfScanbeam(const TopY: Int64); var E, EPrev, ENext: PEdge; Hj: PHorzRec; Pt, Pt2: TIntPoint; IntermediateVert: Boolean; begin (******************************************************************************* * Notes: Processing edges at scanline intersections (ie at the top or bottom * * of A scanbeam) needs to be done in multiple stages and in the correct order. * * Firstly, edges forming A 'maxima' need to be processed and then removed. * * Next, 'intermediate' and 'maxima' horizontal edges are processed. Then edges * * that intersect exactly at the top of the scanbeam are processed [%]. * * Finally, new minima are added and any intersects they create are processed. * *******************************************************************************) (******************************************************************************* * \ / / \ / * * \ Horizontal minima / / \ / * * { -- o======================#====o -------- . ------------------- } * * { Horizontal maxima . % scanline intersect } * * { -- o=======================#===================#========o ---------- } * * | / / \ \ * * + maxima intersect / / \ \ * * /|\ / / \ \ * * / | \ / / \ \ * *******************************************************************************) E := FActiveEdges; while Assigned(E) do begin //1. process maxima, treating them as if they're 'bent' horizontal edges, // but exclude maxima with Horizontal edges. nb: E can't be A Horizontal. if IsMaxima(E, TopY) and (GetMaximaPair(E).Dx <> CHorizontal) then begin //'E' might be removed from AEL, as may any following edges so ... EPrev := E.PrevInAEL; DoMaxima(E, TopY); if not Assigned(EPrev) then E := FActiveEdges else E := EPrev.NextInAEL; end else begin IntermediateVert := IsIntermediate(E, TopY); //2. promote horizontal edges, otherwise update XCurr and YCurr ... if IntermediateVert and (E.NextInLML.Dx = CHorizontal) then begin if (E.OutIdx >= 0) then begin AddOutPt(E, IntPoint(E.XTop, E.YTop)); Hj := FHorizJoins; if Assigned(Hj) then repeat if GetOverlapSegment(IntPoint(Hj.Edge.XBot, Hj.Edge.YBot), IntPoint(Hj.Edge.XTop, Hj.Edge.YTop), IntPoint(E.NextInLML.XBot, E.NextInLML.YBot), IntPoint(E.NextInLML.XTop, E.NextInLML.YTop), Pt, Pt2) then AddJoin(Hj.Edge, E.NextInLML, Hj.SavedIdx, E.OutIdx); Hj := Hj.Next; until Hj = FHorizJoins; AddHorzJoin(E.NextInLML, E.OutIdx); end; UpdateEdgeIntoAEL(E); AddEdgeToSEL(E); end else begin E.XCurr := TopX(E, TopY); E.YCurr := TopY; if FForceSimple and Assigned(E.PrevInAEL) and (E.PrevInAEL.XCurr = E.XCurr) and (E.OutIdx >= 0) and (E.PrevInAEL.OutIdx >= 0) then begin if IntermediateVert then AddOutPt(E.PrevInAEL, IntPoint(E.XCurr, TopY)) else AddOutPt(E, IntPoint(E.XCurr, TopY)); end; end; E := E.NextInAEL; end; end; //3. Process horizontals at the top of the scanbeam ... ProcessHorizontals; //4. Promote intermediate vertices ... E := FActiveEdges; while Assigned(E) do begin if IsIntermediate(E, TopY) then begin if (E.OutIdx >= 0) then AddOutPt(E, IntPoint(E.XTop, E.YTop)); UpdateEdgeIntoAEL(E); // if output polygons share an Edge, they'll need joining later ... EPrev := E.PrevInAEL; ENext := E.NextInAEL; if Assigned(EPrev) and (EPrev.XCurr = E.XBot) and (EPrev.YCurr = E.YBot) and (E.OutIdx >= 0) and (EPrev.OutIdx >= 0) and (EPrev.YCurr > EPrev.YTop) and SlopesEqual(E, EPrev, FUse64BitRange) then begin AddOutPt(EPrev, IntPoint(E.XBot, E.YBot)); AddJoin(E, EPrev); end else if Assigned(ENext) and (ENext.XCurr = E.XBot) and (ENext.YCurr = E.YBot) and (E.OutIdx >= 0) and (ENext.OutIdx >= 0) and (ENext.YCurr > ENext.YTop) and SlopesEqual(E, ENext, FUse64BitRange) then begin AddOutPt(ENext, IntPoint(E.XBot, E.YBot)); AddJoin(E, ENext); end; end; E := E.NextInAEL; end; end; //------------------------------------------------------------------------------ function TClipper.GetResultAsFloatPoints: TArrayOfArrayOfFloatPoint; var I, J, K, Cnt: Integer; OutRec: POutRec; Op: POutPt; begin J := 0; SetLength(Result, FPolyOutList.Count); for I := 0 to FPolyOutList.Count - 1 do if Assigned(fPolyOutList[I]) then begin OutRec := FPolyOutList[I]; Cnt := PointCount(OutRec.Pts); if (Cnt < 3) then Continue; SetLength(Result[J], Cnt); Op := OutRec.Pts; for K := 0 to Cnt - 1 do begin Result[J][K] := IntPointToFloatPoint(Op.Pt); Op := Op.Prev; end; inc(J); end; SetLength(Result, J); end; //------------------------------------------------------------------------------ function TClipper.GetResultAsFixedPoints: TArrayOfArrayOfFixedPoint; var I, J, K, Cnt: Integer; OutRec: POutRec; Op: POutPt; begin J := 0; SetLength(Result, FPolyOutList.Count); for I := 0 to FPolyOutList.Count - 1 do if Assigned(fPolyOutList[I]) then begin OutRec := FPolyOutList[I]; Cnt := PointCount(Op); if (Cnt < 3) then Continue; SetLength(Result[J], Cnt); Op := OutRec.Pts; for K := 0 to Cnt - 1 do begin Result[J][K] := IntPointToFixedPoint(Op.Pt); Op := Op.Prev; end; inc(J); end; SetLength(Result, J); end; //------------------------------------------------------------------------------ procedure TClipper.FixupOutPolygon(OutRec: POutRec); var PP, Tmp, LastOK: POutPt; begin // FixupOutPolygon() - removes duplicate points and simplifies consecutive // parallel edges by removing the middle vertex. LastOK := nil; OutRec.BottomPt := nil; PP := OutRec.Pts; while True do begin if (PP.Prev = PP) or (PP.Next = PP.Prev) then begin DisposePolyPts(PP); OutRec.Pts := nil; Exit; end; // test for duplicate points and for colinear edges ... if PointsEqual(PP.Pt, PP.Next.Pt) or SlopesEqual(PP.Prev.Pt, PP.Pt, PP.Next.Pt, FUse64BitRange) then begin // OK, we need to delete A point ... LastOK := nil; Tmp := PP; PP.Prev.Next := PP.Next; PP.Next.Prev := PP.Prev; PP := PP.Prev; dispose(Tmp); end else if PP = LastOK then break else begin if not Assigned(LastOK) then LastOK := PP; PP := PP.Next; end; end; OutRec.Pts := PP; end; //------------------------------------------------------------------------------ function EdgesAdjacent(Inode: PIntersectNode): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := (Inode.Edge1.NextInSEL = Inode.Edge2) or (Inode.Edge1.PrevInSEL = Inode.Edge2); end; //------------------------------------------------------------------------------ function TClipper.FixupIntersectionOrder: Boolean; var Inode, NextNode: PIntersectNode; begin //pre-condition: intersections are sorted bottom-most first. //Now it's crucial that intersections are made only between adjacent edges, //and to ensure this the order of intersections may need adjusting ... Result := True; Inode := FIntersectNodes; CopyAELToSEL; while Assigned(Inode) do begin if not EdgesAdjacent(Inode) then begin NextNode := Inode.Next; while (assigned(NextNode) and not EdgesAdjacent(NextNode)) do NextNode := NextNode.Next; if not assigned(NextNode) then begin Result := False; Exit; //error!! end; SwapIntersectNodes(Inode, NextNode); end; SwapPositionsInSEL(Inode.Edge1, Inode.Edge2); Inode := Inode.Next; end; end; //------------------------------------------------------------------------------ procedure TClipper.SwapIntersectNodes(Int1, Int2: PIntersectNode); var Int: TIntersectNode; begin //just swap the contents (because fIntersectNodes is a single-linked-list) Int := Int1^; //gets a copy of Int1 Int1.Edge1 := Int2.Edge1; Int1.Edge2 := Int2.Edge2; Int1.Pt := Int2.Pt; Int2.Edge1 := Int.Edge1; Int2.Edge2 := Int.Edge2; Int2.Pt := Int.Pt; end; //------------------------------------------------------------------------------ function FindSegment(var PP: POutPt; var Pt1, Pt2: TIntPoint): Boolean; var Pp2: POutPt; Pt1a, Pt2a: TIntPoint; begin if not Assigned(PP) then begin Result := False; Exit; end; Result := True; Pt1a := Pt1; Pt2a := Pt2; Pp2 := PP; repeat // test for co-linearity before testing for overlap ... if SlopesEqual(Pt1a, Pt2a, PP.Pt, PP.Prev.Pt, True) and SlopesEqual(Pt1a, Pt2a, PP.Pt, True) and GetOverlapSegment(Pt1a, Pt2a, PP.Pt, PP.Prev.Pt, Pt1, Pt2) then Exit; PP := PP.Next; until PP = Pp2; Result := False; end; //------------------------------------------------------------------------------ function Pt3IsBetweenPt1AndPt2(const Pt1, Pt2, Pt3: TIntPoint): Boolean; begin if PointsEqual(Pt1, Pt3) or PointsEqual(Pt2, Pt3) then Result := True else if (Pt1.X <> Pt2.X) then Result := (Pt1.X < Pt3.X) = (Pt3.X < Pt2.X) else Result := (Pt1.Y < Pt3.Y) = (Pt3.Y < Pt2.Y); end; //------------------------------------------------------------------------------ function InsertPolyPtBetween(p1, P2: POutPt; const Pt: TIntPoint): POutPt; begin if (p1 = P2) then raise exception.Create(rsJoinError); new(Result); Result.Pt := Pt; Result.Idx := p1.Idx; if P2 = p1.Next then begin p1.Next := Result; P2.Prev := Result; Result.Next := P2; Result.Prev := p1; end else begin P2.Next := Result; p1.Prev := Result; Result.Next := p1; Result.Prev := P2; end; end; //------------------------------------------------------------------------------ function TClipper.JoinPoints(JR: PJoinRec; out P1, P2: POutPt): Boolean; var OutRec1, OutRec2: POutRec; Prev, P3, P4, Pp1a, Pp2a: POutPt; Pt1, Pt2, Pt3, Pt4: TIntPoint; begin Result := False; OutRec1 := FPolyOutList[Jr.Poly1Idx]; OutRec2 := FPolyOutList[Jr.Poly2Idx]; if not assigned(OutRec1) then Exit; if not assigned(OutRec2) then Exit; Pp1a := OutRec1.Pts; Pp2a := OutRec2.Pts; Pt1 := Jr.Pt2a; Pt2 := Jr.Pt2b; Pt3 := Jr.Pt1a; Pt4 := Jr.Pt1b; if not FindSegment(Pp1a, Pt1, Pt2) then Exit; if (OutRec1 = OutRec2) then begin //we're searching the same polygon for overlapping segments so //segment 2 mustn't be the same as segment 1 ... Pp2a := Pp1a.Next; if not FindSegment(Pp2a, Pt3, Pt4) or (Pp2a = Pp1a) then Exit; end else if not FindSegment(Pp2a, Pt3, Pt4) then Exit; if not GetOverlapSegment(Pt1, Pt2, Pt3, Pt4, Pt1, Pt2) then Exit; Prev := Pp1a.Prev; if PointsEqual(Pp1a.Pt, Pt1) then P1 := Pp1a else if PointsEqual(Prev.Pt, Pt1) then P1 := Prev else P1 := InsertPolyPtBetween(Pp1a, Prev, Pt1); if PointsEqual(Pp1a.Pt, Pt2) then P2 := Pp1a else if PointsEqual(Prev.Pt, Pt2) then P2 := Prev else if (P1 = Pp1a) or (P1 = Prev) then P2 := InsertPolyPtBetween(Pp1a, Prev, Pt2) else if Pt3IsBetweenPt1AndPt2(Pp1a.Pt, P1.Pt, Pt2) then P2 := InsertPolyPtBetween(Pp1a, P1, Pt2) else P2 := InsertPolyPtBetween(P1, Prev, Pt2); Prev := Pp2a.Prev; if PointsEqual(Pp2a.Pt, Pt1) then P3 := Pp2a else if PointsEqual(Prev.Pt, Pt1) then P3 := Prev else P3 := InsertPolyPtBetween(Pp2a, Prev, Pt1); if PointsEqual(Pp2a.Pt, Pt2) then P4 := Pp2a else if PointsEqual(Prev.Pt, Pt2) then P4 := Prev else if (P3 = Pp2a) or (P3 = Prev) then P4 := InsertPolyPtBetween(Pp2a, Prev, Pt2) else if Pt3IsBetweenPt1AndPt2(Pp2a.Pt, P3.Pt, Pt2) then P4 := InsertPolyPtBetween(Pp2a, P3, Pt2) else P4 := InsertPolyPtBetween(P3, Prev, Pt2); if (P1.Next = P2) and (P3.Prev = P4) then begin P1.Next := P3; P3.Prev := P1; P2.Prev := P4; P4.Next := P2; Result := True; end else if (P1.Prev = P2) and (P3.Next = P4) then begin P1.Prev := P3; P3.Next := P1; P2.Next := P4; P4.Prev := P2; Result := True; end; end; //------------------------------------------------------------------------------ procedure TClipper.FixupJoinRecs(JR: PJoinRec; Pt: POutPt; StartIdx: integer); var JR2: PJoinRec; begin for StartIdx := StartIdx to FJoinList.count -1 do begin Jr2 := FJoinList[StartIdx]; if (Jr2.Poly1Idx = Jr.Poly1Idx) and PointIsVertex(Jr2.Pt1a, Pt) then Jr2.Poly1Idx := Jr.Poly2Idx; if (Jr2.Poly2Idx = Jr.Poly1Idx) and PointIsVertex(Jr2.Pt2a, Pt) then Jr2.Poly2Idx := Jr.Poly2Idx; end; end; //------------------------------------------------------------------------------ function Poly2ContainsPoly1(OutPt1, OutPt2: POutPt; UseFullInt64Range: Boolean): Boolean; var Pt: POutPt; begin Pt := OutPt1; //Because the polygons may be touching, we need to find a vertex that //isn't touching the other polygon ... if PointOnPolygon(Pt.Pt, OutPt2, UseFullInt64Range) then begin Pt := Pt.Next; while (Pt <> OutPt1) and PointOnPolygon(Pt.Pt, OutPt2, UseFullInt64Range) do Pt := Pt.Next; if (Pt = OutPt1) then begin Result := true; Exit; end; end; Result := PointInPolygon(Pt.Pt, OutPt2, UseFullInt64Range); end; //------------------------------------------------------------------------------ procedure TClipper.JoinCommonEdges; var I: Integer; Jr: PJoinRec; OutRec1, OutRec2, HoleStateRec: POutRec; P1, P2: POutPt; begin for I := 0 to FJoinList.count -1 do begin Jr := FJoinList[I]; OutRec1 := GetOutRec(Jr.Poly1Idx); OutRec2 := GetOutRec(Jr.Poly2Idx); if not Assigned(OutRec1.Pts) or not Assigned(OutRec2.Pts) then Continue; //get the polygon fragment with the correct hole state (FirstLeft) //before calling JoinPoints() ... if OutRec1 = OutRec2 then HoleStateRec := OutRec1 else if Param1RightOfParam2(OutRec1, OutRec2) then HoleStateRec := OutRec2 else if Param1RightOfParam2(OutRec2, OutRec1) then HoleStateRec := OutRec1 else HoleStateRec := GetLowermostRec(OutRec1, OutRec2); if not JoinPoints(JR, P1, P2) then Continue; if (OutRec1 = OutRec2) then begin //instead of joining two polygons, we've just created a new one by //splitting one polygon into two. OutRec1.Pts := P1; OutRec1.BottomPt := nil; OutRec2 := CreateOutRec; OutRec2.Pts := P2; Jr.Poly2Idx := OutRec2.Idx; if Poly2ContainsPoly1(OutRec2.Pts, OutRec1.Pts, FUse64BitRange) then begin //OutRec2 is contained by OutRec1 ... OutRec2.IsHole := not OutRec1.IsHole; OutRec2.FirstLeft := OutRec1; //now fixup any subsequent joins that match the new polygon ... FixupJoinRecs(Jr, P2, I + 1); FixupOutPolygon(OutRec1); //nb: do this BEFORE testing orientation FixupOutPolygon(OutRec2); // but AFTER calling FixupJoinRecs() if (OutRec2.IsHole xor FReverseOutput) = (Area(OutRec2, FUse64BitRange) > 0) then ReversePolyPtLinks(OutRec2.Pts); end else if Poly2ContainsPoly1(OutRec1.Pts, OutRec2.Pts, FUse64BitRange) then begin //OutRec1 is contained by OutRec2 ... OutRec2.IsHole := OutRec1.IsHole; OutRec1.IsHole := not OutRec2.IsHole; OutRec2.FirstLeft := OutRec1.FirstLeft; OutRec1.FirstLeft := OutRec2; //now fixup any subsequent joins that match the new polygon ... FixupJoinRecs(Jr, P2, I + 1); FixupOutPolygon(OutRec1); //nb: do this BEFORE testing orientation FixupOutPolygon(OutRec2); // but AFTER calling PointIsVertex() if (OutRec1.IsHole xor FReverseOutput) = (Area(OutRec1, FUse64BitRange) > 0) then ReversePolyPtLinks(OutRec1.Pts); end else begin //the 2 polygons are completely separate ... OutRec2.IsHole := OutRec1.IsHole; OutRec2.FirstLeft := OutRec1.FirstLeft; //now fixup any subsequent joins that match the new polygon ... FixupJoinRecs(Jr, P2, I + 1); FixupOutPolygon(OutRec1); //nb: do this AFTER calling PointIsVertex() FixupOutPolygon(OutRec2); // in FixupJoinRecs() end; end else begin //joined 2 polygons together ... //cleanup edges ... FixupOutPolygon(OutRec1); //delete the obsolete pointer ... OutRec2.Pts := nil; OutRec2.BottomPt := nil; OutRec2.Idx := OutRec1.Idx; OutRec1.IsHole := HoleStateRec.IsHole; if HoleStateRec = OutRec2 then OutRec1.FirstLeft := OutRec2.FirstLeft; OutRec2.FirstLeft := OutRec1; end; end; end; //------------------------------------------------------------------------------ procedure UpdateOutPtIdxs(OutRec: POutRec); var op: POutPt; begin op := OutRec.Pts; repeat op.Idx := OutRec.Idx; op := op.Prev; until op = OutRec.Pts; end; //------------------------------------------------------------------------------ procedure TClipper.DoSimplePolygons; var I: Integer; OutRec1, OutRec2: POutRec; Op, Op2, Op3, Op4: POutPt; begin I := 0; while I < FPolyOutList.Count do begin OutRec1 := POutRec(fPolyOutList[I]); inc(I); Op := OutRec1.Pts; if not assigned(OP) then Continue; repeat //for each Pt in Polygon until duplicate found do ... Op2 := Op.Next; while (Op2 <> OutRec1.Pts) do begin if (PointsEqual(Op.Pt, Op2.Pt) and (Op2.Next <> Op)and (Op2.Prev <> Op)) then begin //split the polygon into two ... Op3 := Op.Prev; Op4 := Op2.Prev; Op.Prev := Op4; Op4.Next := Op; Op2.Prev := Op3; Op3.Next := Op2; OutRec1.Pts := Op; OutRec2 := CreateOutRec; OutRec2.Pts := Op2; UpdateOutPtIdxs(OutRec2); if Poly2ContainsPoly1(OutRec2.Pts, OutRec1.Pts, FUse64BitRange) then begin //OutRec2 is contained by OutRec1 ... OutRec2.IsHole := not OutRec1.IsHole; OutRec2.FirstLeft := OutRec1; end else if Poly2ContainsPoly1(OutRec1.Pts, OutRec2.Pts, FUse64BitRange) then begin //OutRec1 is contained by OutRec2 ... OutRec2.IsHole := OutRec1.IsHole; OutRec1.IsHole := not OutRec2.IsHole; OutRec2.FirstLeft := OutRec1.FirstLeft; OutRec1.FirstLeft := OutRec2; end else begin //the 2 polygons are separate ... OutRec2.IsHole := OutRec1.IsHole; OutRec2.FirstLeft := OutRec1.FirstLeft; end; Op2 := Op; //ie get ready for the next iteration end; Op2 := Op2.Next; end; Op := Op.Next; until (Op = OutRec1.Pts); end; end; //------------------------------------------------------------------------------ // InflatePolygons ... //------------------------------------------------------------------------------ function GetUnitNormal(const Pt1, Pt2: TFloatPoint): TDoublePoint; var Dx, Dy, F: TFloat; begin if (Abs(Pt2.X - Pt1.X) < 0.000000001) and (Abs(Pt2.Y - Pt1.Y) < 0.000000001) then begin Result.X := 0; Result.Y := 0; Exit; end; Dx := (Pt2.X - Pt1.X); Dy := (Pt2.Y - Pt1.Y); F := 1 / Math.Hypot(Dx, Dy); Result.X := Dy * F; Result.Y := -Dx * F; end; //------------------------------------------------------------------------------ //Notes on the number of steps used to build an arc: //Given S = arbitrary no. steps used to construct chords approximating a CIRCLE, //then the angle (A) of each step = 2 * Pi / S //The chord between two steps (pt1) & (pt2) is perpendicular to the line //segment between the circle's center (pt3) to the chord's midpoint (pt4). //Let the length of the line segment (pt3) & (Pt4) = D, and let the distance //from the chord's midpoint (pt4) to the circle = Q, such that R - Q = D //If Q is a pre-defined constant (ie the maximum allowed deviation from circle), //then given that cos(angle) = adjacent/hypotenuse ... // cos(A/2) = D/R // = (R - Q)/R // = 1 - Q/R // A/2 = ArcCos(1 - Q/R) // A = 2 * ArcCos(1 - Q/R) //2 * Pi / S = 2 * ArcCos(1 - Q/R) // S = Pi / ArcCos(1 - Q/R) //Instead of a CIRCLE, given an ARC from angle A1 to angle A2 ... // ArcFrac = Abs(A2 - A1)/(2 * Pi) // Steps = ArcFrac * Pi / ArcCos(1 - Q/R) // Steps = Abs(A2 - A1) / (2 * ArcCos(1 - Q/R)) function BuildArc(const Pt: TFloatPoint; A1, A2, R: Single; Tolerance: Double): TArrayOfFloatPoint; var I: Integer; Steps: Int64; X, X2, Y: Double; S, C: Extended; begin Steps := Trunc(Abs(A2 - A1) / (2* ArcCos(1 - Tolerance / Abs(R)))); if Steps < 2 then Steps := 2; Math.SinCos(A1, S, C); X := C; Y := S; Math.SinCos((A2 - A1) / Steps, S, C); SetLength(Result, Steps + 1); for I := 0 to Steps do begin Result[I].X := Pt.X + X * R; Result[I].Y := Pt.Y + Y * R; X2 := X; X := X * C - S * Y; //cross product & dot product here ... Y := X2 * S + Y * C; //avoids repeat calls to the much slower SinCos() end; end; //------------------------------------------------------------------------------ function GetBounds(const Pts: TArrayOfArrayOfFloatPoint): TFloatRect; var I,J: Integer; begin with Result do begin Left := CHiRange; Top := CHiRange; Right := -CHiRange; Bottom := -CHiRange; end; for I := 0 to High(Pts) do for J := 0 to High(Pts[I]) do begin if Pts[I, J].X < Result.Left then Result.Left := Pts[I, J].X; if Pts[I, J].X > Result.Right then Result.Right := Pts[I, J].X; if Pts[I, J].Y < Result.Top then Result.Top := Pts[I, J].Y; if Pts[I, J].Y > Result.Bottom then Result.Bottom := Pts[I, J].Y; end; if Result.Left = CHiRange then Result := FloatRect(0, 0, 0, 0); end; //------------------------------------------------------------------------------ function InflatePolygons(const FltPts: TArrayOfArrayOfFloatPoint; const Delta: TFloat; JoinType: TJoinType = jtSquare; Limit: TFloat = 0; AutoFix: Boolean = True): TArrayOfArrayOfFloatPoint; var I, J, K, Len, OutLen, BotI: Integer; Normals: TArrayOfDoublePoint; R, RMin: Double; Pt1, Pt2: TFloatPoint; Outer: TArrayOfFloatPoint; Bounds: TFloatRect; Pts: TArrayOfArrayOfFloatPoint; BotPt: TFloatPoint; const BuffLength: Integer = 128; procedure AddPoint(const Pt: TFloatPoint); begin if OutLen = length(Result[I]) then SetLength(Result[I], OutLen + BuffLength); Result[I, OutLen] := Pt; Inc(OutLen); end; procedure DoSquare(mul: Double = 1.0); var A1, A2, Dx: Double; begin Pt1.X := Pts[I, J].X + Normals[K].X * Delta; Pt1.Y := Pts[I, J].Y + Normals[K].Y * Delta; Pt2.X := Pts[I, J].X + Normals[J].X * Delta; Pt2.Y := Pts[I, J].Y + Normals[J].Y * Delta; if ((Normals[K].X * Normals[J].Y - Normals[J].X * Normals[K].Y) * Delta >= 0) then begin A1 := ArcTan2(Normals[K].Y, Normals[K].X); A2 := ArcTan2(-Normals[J].Y, -Normals[J].X); A1 := Abs(A2 - A1); if A1 > Pi then A1 := 2 * Pi - A1; Dx := Tan((Pi - A1) * 0.125) * Abs(Delta * mul); Pt1 := FloatPoint(Pt1.X -Normals[K].Y * Dx, Pt1.Y + Normals[K].X * Dx); AddPoint(Pt1); Pt2 := FloatPoint(Pt2.X + Normals[J].Y * Dx, Pt2.Y - Normals[J].X * Dx); AddPoint(Pt2); end else begin AddPoint(Pt1); AddPoint(Pts[I, J]); AddPoint(Pt2); end; end; procedure DoMiter; var Q: Double; begin if ((Normals[K].X * Normals[J].Y - Normals[J].X * Normals[K].Y) * Delta >= 0) then begin Q := Delta / R; AddPoint(FloatPoint(Pts[I, J].X + (Normals[K].X + Normals[J].X) * Q, Pts[I, J].Y + (Normals[K].Y + Normals[J].Y) *Q)); end else begin Pt1.X := Pts[I, J].X + Normals[K].X * Delta; Pt1.Y := Pts[I, J].Y + Normals[K].Y * Delta; Pt2.X := Pts[I, J].X + Normals[J].X * Delta; Pt2.Y := Pts[I, J].Y + Normals[J].Y * Delta; AddPoint(Pt1); AddPoint(Pts[I, J]); AddPoint(Pt2); end; end; procedure DoRound(Limit: Double); var M: Integer; Arc: TArrayOfFloatPoint; A1, A2: Double; begin Pt1.X := Pts[I, J].X + Normals[K].X * Delta; Pt1.Y := Pts[I, J].Y + Normals[K].Y * Delta; Pt2.X := Pts[I, J].X + Normals[J].X * Delta; Pt2.Y := Pts[I, J].Y + Normals[J].Y * Delta; AddPoint(Pt1); // round off reflex angles (ie > 180 deg) unless almost flat (ie < 10deg). //(N1.X * N2.Y - N2.X * N1.Y) == unit normal "cross product" == sin(angle) //(N1.X * N2.X + N1.Y * N2.Y) == unit normal "dot product" == cos(angle) // dot product Normals == 1 -> no angle if ((Normals[K].X * Normals[J].Y - Normals[J].X * Normals[K].Y) * Delta >= 0) then begin if ((Normals[J].X * Normals[K].X + Normals[J].Y * Normals[K].Y) < 0.985) then begin A1 := ArcTan2(Normals[K].Y, Normals[K].X); A2 := ArcTan2(Normals[J].Y, Normals[J].X); if (Delta > 0) and (A2 < A1) then A2 := A2 + Pi * 2 else if (Delta < 0) and (A2 > A1) then A2 := A2 - Pi * 2; Arc := BuildArc(Pts[I, J], A1, A2, Delta, Limit); for M := 1 to High(Arc) - 1 do AddPoint(Arc[M]); end; end else AddPoint(Pts[I, J]); AddPoint(Pt2); end; function UpdateBotPt(const Pt: TFloatPoint; var BotPt: TFloatPoint): Boolean; begin if (pt.Y > BotPt.Y) or ((pt.Y = BotPt.Y) and (Pt.X < BotPt.X)) then begin BotPt := Pt; Result := True; end else Result := False; end; begin result := nil; //CheckInputs - fixes polygon orientation if necessary and removes //duplicate vertices. Can be set false when you're sure that polygon //orientation is correct and that there are no duplicate vertices. if AutoFix then begin Len := Length(FltPts); SetLength(Pts, Len); BotI := 0; //index of outermost polygon while (BotI < Len) and (Length(FltPts[BotI]) = 0) do Inc(BotI); if (BotI = Len) then Exit; BotPt := FltPts[BotI][0]; for I := BotI to Len - 1 do begin Len := Length(FltPts[I]); SetLength(Pts[I], Len); if Len = 0 then Continue; Pts[I][0] := FltPts[I][0]; if UpdateBotPt(Pts[I][0], BotPt) then BotI := I; K := 0; for J := 1 to Len - 1 do if (Pts[I][K].X <> FltPts[I][J].X) and (Pts[I][K].Y <> FltPts[I][J].Y) then begin Inc(K); Pts[I][K] := FltPts[I][J]; if UpdateBotPt(Pts[I][K], BotPt) then BotI := I; end; if K + 1 < Len then SetLength(Pts[I], K + 1); end; if not Orientation(Pts[BotI]) then Pts := ReversePolygons(Pts); end else Pts := FltPts; case JoinType of jtRound: if Limit <= 0 then Limit := 0.25 else if Limit > abs(Delta) then Limit := abs(Delta); jtMiter: if Limit < 2 then Limit := 2; else Limit := 1; end; RMin := 2/(sqr(Limit)); SetLength(Result, length(Pts)); for I := 0 to High(Pts) do begin Result[I] := nil; Len := length(Pts[I]); if (Len > 1) and (Pts[I, 0].X = Pts[I, Len - 1].X) and (Pts[I, 0].Y = Pts[I, Len - 1].Y) then Dec(Len); if (Len < 3) and (Delta < 0) then Continue; if (Len = 1) then begin Result[I] := BuildArc(Pts[I, 0], 0, 2 * Pi, Delta, Limit); Continue; end; // build Normals ... SetLength(Normals, Len); for J := 0 to Len - 2 do Normals[J] := GetUnitNormal(Pts[I, J], Pts[I, J + 1]); Normals[Len - 1] := GetUnitNormal(Pts[I, Len - 1], Pts[I, 0]); OutLen := 0; K := Len - 1; for J := 0 to Len - 1 do begin case JoinType of jtMiter: begin R := 1 + (Normals[J].X * Normals[K].X + Normals[J].Y * Normals[K].Y); if (R >= RMin) then DoMiter else DoSquare(Limit); end; jtSquare: DoSquare(1); jtRound: DoRound(Limit); end; K := J; end; SetLength(Result[I], OutLen); end; // finally, clean up untidy corners ... with TClipper.Create do try Add(Result, ptSubject); if Delta > 0 then begin Execute(ctUnion, Result, pftPositive, pftPositive); end else begin Bounds := GetBounds(Result); SetLength(Outer, 4); Outer[0] := FloatPoint(Bounds.Left - 10, Bounds.Bottom + 10); Outer[1] := FloatPoint(Bounds.Right + 10, Bounds.Bottom + 10); Outer[2] := FloatPoint(Bounds.Right + 10, Bounds.Top - 10); Outer[3] := FloatPoint(Bounds.Left - 10, Bounds.Top - 10); Add(Outer, ptSubject); Execute(ctUnion, Result, pftNegative, pftNegative); // delete the outer rectangle ... Len := length(Result); for J := 1 to Len - 1 do Result[J - 1] := Result[J]; if Len > 0 then SetLength(Result, Len - 1); // restore polygon orientation ... Result := ReversePolygons(Result); end; finally Free; end; end; //------------------------------------------------------------------------------ function SimplifyPolygon(const Poly: TArrayOfFloatPoint; FillType: TPolyFillType = pftEvenOdd): TArrayOfArrayOfFloatPoint; begin with TClipper.Create do try ForceSimple := True; Add(Poly, ptSubject); Execute(ctUnion, Result, FillType, FillType); finally free; end; end; //------------------------------------------------------------------------------ function SimplifyPolygons(const Polys: TArrayOfArrayOfFloatPoint; FillType: TPolyFillType = pftEvenOdd): TArrayOfArrayOfFloatPoint; begin with TClipper.Create do try ForceSimple := True; Add(Polys, ptSubject); Execute(ctUnion, Result, FillType, FillType); finally free; end; end; //------------------------------------------------------------------------------ function DistanceSqrd(const Pt1, Pt2: TFloatPoint): TFloat; {$IFDEF INLINING} inline; {$ENDIF} var dx, dy: TFloat; begin dx := (Pt1.X - Pt2.X); dy := (Pt1.Y - Pt2.Y); result := (dx*dx + dy*dy); end; //------------------------------------------------------------------------------ function ClosestPointOnLine(const Pt, LinePt1, LinePt2: TFloatPoint): TFloatPoint; var dx, dy, q: TFloat; begin dx := (LinePt2.X-LinePt1.X); dy := (LinePt2.Y-LinePt1.Y); if (dx = 0) and (dy = 0) then q := 0 else q := ((Pt.X-LinePt1.X)*dx + (Pt.Y-LinePt1.Y)*dy) / (dx*dx + dy*dy); Result.X := (1-q)*LinePt1.X + q*LinePt2.X; Result.Y := (1-q)*LinePt1.Y + q*LinePt2.Y; end; //------------------------------------------------------------------------------ function SlopesNearColinear(const Pt1, Pt2, Pt3: TFloatPoint; DistSqrd: TFloat): Boolean; var Cpol: TFloatPoint; Dx, Dy: TFloat; begin Result := false; if DistanceSqrd(Pt1, Pt2) > DistanceSqrd(Pt1, Pt3) then exit; Cpol := ClosestPointOnLine(Pt2, Pt1, Pt3); Dx := Pt2.X - Cpol.X; Dy := Pt2.Y - Cpol.Y; result := (Dx*Dx + Dy*Dy) < DistSqrd; end; //------------------------------------------------------------------------------ function PointsAreClose(const Pt1, Pt2: TFloatPoint; DistSqrd: TFloat): Boolean; begin result := DistanceSqrd(Pt1, Pt2) <= DistSqrd; end; //------------------------------------------------------------------------------ function CleanPolygon(Poly: TArrayOfFloatPoint; Distance: Double = 1.415): TArrayOfFloatPoint; var I, I2, J, K, HighI: Integer; DistSqrd: TFloat; Pt: TFloatPoint; begin //Distance = proximity in units/pixels below which vertices //will be stripped. Default ~= sqrt(2) so when adjacent //vertices have both x & y coords within 1 unit, then //the second vertex will be stripped. DistSqrd := Distance * Distance; HighI := High(Poly); while (HighI > 0) and PointsAreClose(Poly[HighI], Poly[0], DistSqrd) do Dec(HighI); if (HighI < 2) then begin Result := nil; Exit; end; SetLength(Result, HighI +1); Pt := Poly[HighI]; I := 0; K := 0; while true do begin while (I < HighI) and PointsAreClose(Pt, Poly[I+1], DistSqrd) do inc(I,2); I2 := I; while (I < HighI) and PointsAreClose(Poly[I], Poly[I+1], DistSqrd) or SlopesNearColinear(Pt, Poly[I], Poly[I+1], DistSqrd) do inc(I); if I >= highI then Break else if I <> I2 then Continue; Pt := Poly[I]; inc(I); Result[K] := Pt; inc(K); end; if (I <= HighI) then begin Result[K] := Poly[I]; inc(K); end; if (K > 2) and SlopesNearCoLinear(Result[K -2], Result[K -1], Result[0], DistSqrd) then Dec(K); if (K < 3) then Result := nil else if (K <= HighI) then SetLength(Result, K); end; //------------------------------------------------------------------------------ function CleanPolygons(const Polys: TArrayOfArrayOfFloatPoint; Distance: double = 1.415): TArrayOfArrayOfFloatPoint; var I, Len: Integer; begin Len := Length(Polys); SetLength(Result, Len); for I := 0 to Len - 1 do Result[I] := CleanPolygon(Polys[I], Distance); end; //------------------------------------------------------------------------------ //------------------------------------------------------------------------------ end. |
Added src/graphics32/GR32_ColorGradients.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 | unit GR32_ColorGradients; (* ***** BEGIN LICENSE BLOCK *************************************************** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * * * The contents of this file are 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/ * * * * 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. * * * * Alternatively, the contents of this file may be used under the terms of the * * Free Pascal modified version of the GNU Lesser General Public License * * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * * of this license are applicable instead of those above. * * Please see the file LICENSE.txt for additional information concerning this * * license. * * * * The Original Code is Color Gradients for Graphics32 * * * * The Initial Developer of the Original Code is Angus Johnson * * * * Portions created by the Initial Developer are Copyright (C) 2008-2012 * * the Initial Developer. All Rights Reserved. * * * * Contributor(s): Christian Budde <Christian@aixcoustic.com> * * * * ***** END LICENSE BLOCK *****************************************************) interface {$I GR32.inc} uses Types, Classes, SysUtils, Math, GR32, GR32_Polygons, GR32_VectorUtils, GR32_Blend; type TColor32GradientStop = record Offset: TFloat; //expected range between 0.0 and 1.0 Color32: TColor32; end; TArrayOfColor32GradientStop = array of TColor32GradientStop; TColor32FloatPoint = record Point: TFloatPoint; Color32: TColor32; end; TArrayOfColor32FloatPoint = array of TColor32FloatPoint; TColor32LookupTable = class(TPersistent) private FGradientLUT: PColor32Array; FOrder: Byte; FMask: Cardinal; FSize: Cardinal; FOnOrderChanged: TNotifyEvent; procedure SetOrder(const Value: Byte); function GetColor32(Index: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} procedure SetColor32(Index: Integer; const Value: TColor32); protected procedure OrderChanged; procedure AssignTo(Dest: TPersistent); override; public constructor Create(Order: Byte = 9); virtual; destructor Destroy; override; property Order: Byte read FOrder write SetOrder; property Size: Cardinal read FSize; property Mask: Cardinal read FMask; property Color32[Index: Integer]: TColor32 read GetColor32 write SetColor32; property Color32Ptr: PColor32Array read FGradientLUT; property OnOrderChanged: TNotifyEvent read FOnOrderChanged write FOnOrderChanged; end; TColor32Gradient = class(TInterfacedPersistent, IStreamPersist) private FGradientColors: TArrayOfColor32GradientStop; FOnGradientColorsChanged: TNotifyEvent; function GetGradientEntry(Index: Integer): TColor32GradientStop; function GetGradientCount: Integer; {$IFDEF USEINLINING}inline;{$ENDIF} function GetStartColor: TColor32; function GetEndColor: TColor32; procedure SetEndColor(const Value: TColor32); procedure SetStartColor(const Value: TColor32); protected procedure GradientColorsChanged; virtual; procedure AssignTo(Dest: TPersistent); override; public constructor Create(Color: TColor32); overload; constructor Create(StartColor, EndColor: TColor32); overload; constructor Create(const GradientColors: TArrayOfColor32GradientStop); overload; procedure LoadFromStream(Stream: TStream); procedure SaveToStream(Stream: TStream); procedure ClearColorStops; overload; procedure ClearColorStops(Color: TColor32); overload; procedure AddColorStop(Offset: TFloat; Color: TColor32); overload; virtual; procedure AddColorStop(ColorStop: TColor32GradientStop); overload; virtual; procedure SetColors(const GradientColors: array of const); overload; procedure SetColors(const GradientColors: TArrayOfColor32GradientStop); overload; procedure SetColors(const GradientColors: TArrayOfColor32); overload; procedure SetColors(const Palette: TPalette32); overload; function GetColorAt(Offset: TFloat): TColor32; procedure FillColorLookUpTable(var ColorLUT: array of TColor32); overload; procedure FillColorLookUpTable(ColorLUT: PColor32Array; Count: Integer); overload; procedure FillColorLookUpTable(ColorLUT: TColor32LookupTable); overload; property GradientEntry[Index: Integer]: TColor32GradientStop read GetGradientEntry; property GradientCount: Integer read GetGradientCount; property StartColor: TColor32 read GetStartColor write SetStartColor; property EndColor: TColor32 read GetEndColor write SetEndColor; property OnGradientColorsChanged: TNotifyEvent read FOnGradientColorsChanged write FOnGradientColorsChanged; end; TCustomSparsePointGradientSampler = class(TCustomSampler) protected function GetCount: Integer; virtual; abstract; function GetColor(Index: Integer): TColor32; virtual; abstract; function GetPoint(Index: Integer): TFloatPoint; virtual; abstract; function GetColorPoint(Index: Integer): TColor32FloatPoint; virtual; abstract; procedure SetColor(Index: Integer; const Value: TColor32); virtual; abstract; procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); virtual; abstract; procedure SetPoint(Index: Integer; const Value: TFloatPoint); virtual; abstract; public function GetSampleFixed(X, Y: TFixed): TColor32; override; function GetSampleInt(X, Y: Integer): TColor32; override; procedure SetPoints(Points: TArrayOfFloatPoint); virtual; abstract; procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); overload; virtual; abstract; procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); overload; virtual; abstract; property Color[Index: Integer]: TColor32 read GetColor write SetColor; property Point[Index: Integer]: TFloatPoint read GetPoint write SetPoint; property ColorPoint[Index: Integer]: TColor32FloatPoint read GetColorPoint write SetColorPoint; property Count: Integer read GetCount; end; TBarycentricGradientSampler = class(TCustomSparsePointGradientSampler) protected FColorPoints: array [0 .. 2] of TColor32FloatPoint; FDists: array [0 .. 1] of TFloatPoint; function GetCount: Integer; override; function GetColor(Index: Integer): TColor32; override; function GetColorPoint(Index: Integer): TColor32FloatPoint; override; function GetPoint(Index: Integer): TFloatPoint; override; procedure SetColor(Index: Integer; const Value: TColor32); override; procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); override; procedure SetPoint(Index: Integer; const Value: TFloatPoint); override; procedure AssignTo(Dest: TPersistent); override; procedure CalculateBarycentricCoordinates(X, Y: TFloat; out U, V, W: TFloat); {$IFDEF USEINLINING} inline; {$ENDIF} public constructor Create(P1, P2, P3: TColor32FloatPoint); overload; virtual; function IsPointInTriangle(X, Y: TFloat): Boolean; overload; function IsPointInTriangle(const Point: TFloatPoint): Boolean; overload; procedure SetPoints(Points: TArrayOfFloatPoint); override; procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); override; procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); override; procedure PrepareSampling; override; function GetSampleFloat(X, Y: TFloat): TColor32; override; function GetSampleFloatInTriangle(X, Y: TFloat): TColor32; end; TBilinearGradientSampler = class(TCustomSparsePointGradientSampler) protected FColorPoints: array [0 .. 3] of TColor32FloatPoint; FDists: array [0 .. 2] of TFloatPoint; FDot: TFloat; FBiasK0: TFloat; FBiasU: TFloat; FK2Sign: Integer; FK2Value: TFloat; function GetCount: Integer; override; function GetColor(Index: Integer): TColor32; override; function GetColorPoint(Index: Integer): TColor32FloatPoint; override; function GetPoint(Index: Integer): TFloatPoint; override; procedure SetColor(Index: Integer; const Value: TColor32); override; procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); override; procedure SetPoint(Index: Integer; const Value: TFloatPoint); override; procedure AssignTo(Dest: TPersistent); override; public procedure SetPoints(Points: TArrayOfFloatPoint); override; procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); override; procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); override; procedure PrepareSampling; override; function GetSampleFloat(X, Y: TFloat): TColor32; override; end; TCustomArbitrarySparsePointGradientSampler = class(TCustomSparsePointGradientSampler) private FColorPoints: TArrayOfColor32FloatPoint; protected procedure AssignTo(Dest: TPersistent); override; function GetCount: Integer; override; function GetColor(Index: Integer): TColor32; override; function GetColorPoint(Index: Integer): TColor32FloatPoint; override; function GetPoint(Index: Integer): TFloatPoint; override; procedure SetColor(Index: Integer; const Value: TColor32); override; procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); override; procedure SetPoint(Index: Integer; const Value: TFloatPoint); override; public procedure Add(Point: TFloatPoint; Color: TColor32); overload; virtual; procedure Add(const ColorPoint: TColor32FloatPoint); overload; virtual; procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); override; procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); override; procedure SetPoints(Points: TArrayOfFloatPoint); override; procedure Clear; virtual; end; TInvertedDistanceWeightingSampler = class(TCustomArbitrarySparsePointGradientSampler) private FDists: TArrayOfFloat; FUsePower: Boolean; FPower: TFloat; FScaledPower: TFloat; public constructor Create; virtual; procedure PrepareSampling; override; procedure FinalizeSampling; override; function GetSampleFloat(X, Y: TFloat): TColor32; override; property Power: TFloat read FPower write FPower; end; TVoronoiSampler = class(TCustomArbitrarySparsePointGradientSampler) public function GetSampleFloat(X, Y: TFloat): TColor32; override; end; TGourandShadedDelaunayTrianglesSampler = class(TCustomArbitrarySparsePointGradientSampler) private FTriangles: TArrayOfTriangleVertexIndices; FBarycentric: array of TBarycentricGradientSampler; public procedure PrepareSampling; override; procedure FinalizeSampling; override; function GetSampleFloat(X, Y: TFloat): TColor32; override; end; TCustomGradientSampler = class(TCustomSampler) private FGradient: TColor32Gradient; FWrapMode: TWrapMode; procedure SetGradient(const Value: TColor32Gradient); procedure SetWrapMode(const Value: TWrapMode); protected FInitialized: Boolean; procedure AssignTo(Dest: TPersistent); override; procedure GradientChangedHandler(Sender: TObject); procedure GradientSamplerChanged; //de-initializes sampler procedure WrapModeChanged; virtual; procedure UpdateInternals; virtual; abstract; property Initialized: Boolean read FInitialized; public constructor Create(WrapMode: TWrapMode = wmMirror); overload; virtual; constructor Create(ColorGradient: TColor32Gradient); overload; virtual; destructor Destroy; override; procedure PrepareSampling; override; function GetSampleInt(X, Y: Integer): TColor32; override; function GetSampleFixed(X, Y: TFixed): TColor32; override; property Gradient: TColor32Gradient read FGradient write SetGradient; property WrapMode: TWrapMode read FWrapMode write SetWrapMode; end; TCustomGradientLookUpTableSampler = class(TCustomGradientSampler) private FGradientLUT: TColor32LookupTable; FLutPtr: PColor32Array; FLutMask: Integer; FWrapProc: TWrapProc; protected procedure AssignTo(Dest: TPersistent); override; procedure WrapModeChanged; override; procedure UpdateInternals; override; property LutPtr: PColor32Array read FLutPtr; property LutMask: Integer read FLutMask; property WrapProc: TWrapProc read FWrapProc; public constructor Create(WrapMode: TWrapMode = wmMirror); override; destructor Destroy; override; end; TCustomCenterLutGradientSampler = class(TCustomGradientLookUpTableSampler) private FCenter: TFloatPoint; protected procedure AssignTo(Dest: TPersistent); override; procedure Transform(var X, Y: TFloat); virtual; public constructor Create(WrapMode: TWrapMode = wmMirror); override; property Center: TFloatPoint read FCenter write FCenter; end; TConicGradientSampler = class(TCustomCenterLutGradientSampler) private FScale: TFloat; FAngle: TFloat; protected procedure AssignTo(Dest: TPersistent); override; procedure UpdateInternals; override; public function GetSampleFloat(X, Y: TFloat): TColor32; override; property Angle: TFloat read FAngle write FAngle; end; TCustomCenterRadiusLutGradientSampler = class(TCustomCenterLutGradientSampler) private FRadius: TFloat; procedure SetRadius(const Value: TFloat); protected procedure AssignTo(Dest: TPersistent); override; procedure RadiusChanged; virtual; public constructor Create(WrapMode: TWrapMode = wmMirror); override; property Radius: TFloat read FRadius write SetRadius; end; TRadialGradientSampler = class(TCustomCenterRadiusLutGradientSampler) private FScale: TFloat; protected procedure UpdateInternals; override; public function GetSampleFloat(X, Y: TFloat): TColor32; override; end; TCustomCenterRadiusAngleLutGradientSampler = class(TCustomCenterRadiusLutGradientSampler) private FAngle: TFloat; FSinCos: TFloatPoint; procedure SetAngle(const Value: TFloat); protected procedure AssignTo(Dest: TPersistent); override; procedure AngleChanged; virtual; procedure RadiusChanged; override; procedure Transform(var X, Y: TFloat); override; public constructor Create(WrapMode: TWrapMode = wmMirror); override; property Angle: TFloat read FAngle write SetAngle; end; TDiamondGradientSampler = class(TCustomCenterRadiusAngleLutGradientSampler) private FScale: TFloat; protected procedure UpdateInternals; override; public function GetSampleFloat(X, Y: TFloat): TColor32; override; end; TXGradientSampler = class(TCustomCenterRadiusAngleLutGradientSampler) private FScale: TFloat; function GetEndPoint: TFloatPoint; function GetStartPoint: TFloatPoint; procedure SetEndPoint(const Value: TFloatPoint); procedure SetStartPoint(const Value: TFloatPoint); protected procedure UpdateInternals; override; public procedure SimpleGradient(const StartPoint: TFloatPoint; StartColor: TColor32; const EndPoint: TFloatPoint; EndColor: TColor32); virtual; procedure SetPoints(const StartPoint, EndPoint: TFloatPoint); virtual; function GetSampleFloat(X, Y: TFloat): TColor32; override; public property StartPoint: TFloatPoint read GetStartPoint write SetStartPoint; property EndPoint: TFloatPoint read GetEndPoint write SetEndPoint; end; TLinearGradientSampler = class(TXGradientSampler); TXYGradientSampler = class(TCustomCenterRadiusAngleLutGradientSampler) private FScale: TFloat; protected procedure UpdateInternals; override; public function GetSampleFloat(X, Y: TFloat): TColor32; override; end; TXYSqrtGradientSampler = class(TCustomCenterRadiusAngleLutGradientSampler) private FScale: TFloat; protected procedure UpdateInternals; override; public function GetSampleFloat(X, Y: TFloat): TColor32; override; end; TCustomSparsePointGradientPolygonFiller = class(TCustomPolygonFiller) protected function GetCount: Integer; virtual; abstract; function GetColor(Index: Integer): TColor32; virtual; abstract; function GetPoint(Index: Integer): TFloatPoint; virtual; abstract; function GetColorPoint(Index: Integer): TColor32FloatPoint; virtual; abstract; procedure SetColor(Index: Integer; const Value: TColor32); virtual; abstract; procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); virtual; abstract; procedure SetPoint(Index: Integer; const Value: TFloatPoint); virtual; abstract; public procedure SetPoints(Points: TArrayOfFloatPoint); virtual; abstract; procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); overload; virtual; abstract; procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); overload; virtual; abstract; property Color[Index: Integer]: TColor32 read GetColor write SetColor; property Point[Index: Integer]: TFloatPoint read GetPoint write SetPoint; property ColorPoint[Index: Integer]: TColor32FloatPoint read GetColorPoint write SetColorPoint; property Count: Integer read GetCount; end; TBarycentricGradientPolygonFiller = class(TCustomSparsePointGradientPolygonFiller) protected FColorPoints: array [0 .. 2] of TColor32FloatPoint; FDists: array [0 .. 1] of TFloatPoint; function GetCount: Integer; override; function GetColor(Index: Integer): TColor32; override; function GetPoint(Index: Integer): TFloatPoint; override; function GetColorPoint(Index: Integer): TColor32FloatPoint; override; procedure SetColor(Index: Integer; const Value: TColor32); override; procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); override; procedure SetPoint(Index: Integer; const Value: TFloatPoint); override; function GetFillLine: TFillLineEvent; override; procedure FillLine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); class function Linear3PointInterpolation(A, B, C: TColor32; WeightA, WeightB, WeightC: Single): TColor32; public procedure BeginRendering; override; procedure SetPoints(Points: TArrayOfFloatPoint); override; procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); overload; override; procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); overload; override; end; TCustomArbitrarySparsePointGradientPolygonFiller = class(TCustomSparsePointGradientPolygonFiller) private FColorPoints: TArrayOfColor32FloatPoint; protected function GetCount: Integer; override; function GetColor(Index: Integer): TColor32; override; function GetColorPoint(Index: Integer): TColor32FloatPoint; override; function GetPoint(Index: Integer): TFloatPoint; override; procedure SetColor(Index: Integer; const Value: TColor32); override; procedure SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); override; procedure SetPoint(Index: Integer; const Value: TFloatPoint); override; public procedure Add(const Point: TFloatPoint; Color: TColor32); overload; virtual; procedure Add(const ColorPoint: TColor32FloatPoint); overload; virtual; procedure SetColorPoints(ColorPoints: TArrayOfColor32FloatPoint); override; procedure SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); override; procedure SetPoints(Points: TArrayOfFloatPoint); override; procedure Clear; virtual; end; TGourandShadedDelaunayTrianglesPolygonFiller = class(TCustomArbitrarySparsePointGradientPolygonFiller) private FTriangles: TArrayOfTriangleVertexIndices; FBarycentric: array of TBarycentricGradientSampler; protected function GetFillLine: TFillLineEvent; override; procedure FillLine3(Dst: PColor32; DstX, DstY, Count: Integer; AlphaValues: PColor32); procedure FillLine(Dst: PColor32; DstX, DstY, Count: Integer; AlphaValues: PColor32); public procedure BeginRendering; override; end; TCustomGradientPolygonFiller = class(TCustomPolygonFiller) private FGradient: TColor32Gradient; FOwnsGradient: Boolean; FWrapMode: TWrapMode; FWrapProc: TWrapProc; procedure SetWrapMode(const Value: TWrapMode); protected procedure GradientColorsChangedHandler(Sender: TObject); procedure FillLineNone(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineSolid(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure GradientFillerChanged; virtual; procedure WrapModeChanged; virtual; public constructor Create; overload; constructor Create(ColorGradient: TColor32Gradient); overload; virtual; destructor Destroy; override; property Gradient: TColor32Gradient read FGradient; property WrapMode: TWrapMode read FWrapMode write SetWrapMode; end; TCustomGradientLookupTablePolygonFiller = class(TCustomGradientPolygonFiller) private FLUTNeedsUpdate: Boolean; FOwnsLUT: Boolean; FGradientLUT: TColor32LookupTable; FUseLookUpTable: Boolean; function GetLUTNeedsUpdate: Boolean; procedure SetUseLookUpTable(const Value: Boolean); procedure SetGradientLUT(const Value: TColor32LookupTable); protected procedure GradientFillerChanged; override; procedure UseLookUpTableChanged; virtual; procedure LookUpTableChangedHandler(Sender: TObject); property LookUpTableNeedsUpdate: Boolean read GetLUTNeedsUpdate; public constructor Create; reintroduce; overload; constructor Create(LookupTable: TColor32LookupTable); overload; virtual; destructor Destroy; override; property GradientLUT: TColor32LookupTable read FGradientLUT write SetGradientLUT; property UseLookUpTable: Boolean read FUseLookUpTable write SetUseLookUpTable; end; TCustomLinearGradientPolygonFiller = class(TCustomGradientLookupTablePolygonFiller) private FIncline: TFloat; FStartPoint: TFloatPoint; FEndPoint: TFloatPoint; procedure SetStartPoint(const Value: TFloatPoint); procedure SetEndPoint(const Value: TFloatPoint); procedure UpdateIncline; protected procedure EndPointChanged; procedure StartPointChanged; public procedure SimpleGradient(const StartPoint: TFloatPoint; StartColor: TColor32; const EndPoint: TFloatPoint; EndColor: TColor32); virtual; procedure SimpleGradientX(const StartX: TFloat; StartColor: TColor32; const EndX: TFloat; EndColor: TColor32); procedure SimpleGradientY(const StartY: TFloat; StartColor: TColor32; const EndY: TFloat; EndColor: TColor32); procedure SetPoints(const StartPoint, EndPoint: TFloatPoint); virtual; property StartPoint: TFloatPoint read FStartPoint write SetStartPoint; property EndPoint: TFloatPoint read FEndPoint write SetEndPoint; end; TLinearGradientPolygonFiller = class(TCustomLinearGradientPolygonFiller) private function ColorStopToScanLine(Index: Integer; Y: Integer): TFloat; protected function GetFillLine: TFillLineEvent; override; procedure FillLineNegative(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLinePositive(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineVertical(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineVerticalExtreme(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineVerticalPad(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineVerticalPadExtreme(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineVerticalWrap(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineHorizontalPadPos(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineHorizontalPadNeg(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineHorizontalWrapNeg(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineHorizontalWrapPos(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure UseLookUpTableChanged; override; procedure WrapModeChanged; override; public constructor Create(ColorGradient: TColor32Gradient); overload; override; constructor Create(ColorGradient: TColor32Gradient; UseLookupTable: Boolean); overload; virtual; procedure BeginRendering; override; //flags initialized end; TCustomRadialGradientPolygonFiller = class(TCustomGradientLookupTablePolygonFiller) private FEllipseBounds: TFloatRect; procedure SetEllipseBounds(const Value: TFloatRect); protected procedure EllipseBoundsChanged; virtual; abstract; public property EllipseBounds: TFloatRect read FEllipseBounds write SetEllipseBounds; end; TRadialGradientPolygonFiller = class(TCustomRadialGradientPolygonFiller) private FCenter: TFloatPoint; FRadius: TFloatPoint; FRadScale: TFloat; FRadXInv: TFloat; procedure SetCenter(const Value: TFloatPoint); procedure SetRadius(const Value: TFloatPoint); procedure UpdateEllipseBounds; procedure UpdateRadiusScale; protected function GetFillLine: TFillLineEvent; override; procedure EllipseBoundsChanged; override; procedure FillLinePad(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineRepeat(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineReflect(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); public constructor Create(Radius: TFloatPoint); overload; constructor Create(BoundingBox: TFloatRect); overload; constructor Create(Radius, Center: TFloatPoint); overload; procedure BeginRendering; override; property Radius: TFloatPoint read FRadius write SetRadius; property Center: TFloatPoint read FCenter write SetCenter; end; TSVGRadialGradientPolygonFiller = class(TCustomRadialGradientPolygonFiller) private FOffset: TFloatPoint; FRadius: TFloatPoint; FCenter: TFloatPoint; FFocalPt: TFloatPoint; FVertDist: TFloat; FFocalPointNative: TFloatPoint; procedure SetFocalPoint(const Value: TFloatPoint); procedure InitMembers; protected function GetFillLine: TFillLineEvent; override; procedure EllipseBoundsChanged; override; procedure FillLineEllipse(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); public constructor Create(EllipseBounds: TFloatRect); overload; constructor Create(EllipseBounds: TFloatRect; FocalPoint: TFloatPoint); overload; procedure BeginRendering; override; procedure SetParameters(EllipseBounds: TFloatRect); overload; procedure SetParameters(EllipseBounds: TFloatRect; FocalPoint: TFloatPoint); overload; property FocalPoint: TFloatPoint read FFocalPointNative write SetFocalPoint; end; function Color32FloatPoint(Color: TColor32; Point: TFloatPoint): TColor32FloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Color32FloatPoint(Color: TColor32; X, Y: TFloat): TColor32FloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Color32GradientStop(Offset: TFloat; Color: TColor32): TColor32GradientStop; overload; {$IFDEF USEINLINING} inline; {$ENDIF} implementation uses GR32_LowLevel, GR32_System, GR32_Math, GR32_Bindings, GR32_Geometry; resourcestring RCStrIndexOutOfBounds = 'Index out of bounds (%d)'; RCStrWrongFormat = 'Wrong format'; RCStrOnlyExactly3Point = 'Only exactly 3 points expected!'; RCStrPointCountMismatch = 'Point count mismatch'; RCStrNoTColor32LookupTable = 'No TColor32LookupTable object specified'; RCStrNoTColor32Gradient = 'No TColor32Gradient specified'; RCStrNoLookupTablePassed = 'No lookup table passed!'; const CFloatTolerance = 0.001; clNone32: TColor32 = $00000000; procedure FillLineAlpha(var Dst, AlphaValues: PColor32; Count: Integer; Color: TColor32); {$IFDEF USEINLINING}inline;{$ENDIF} var X: Integer; begin for X := 0 to Count - 1 do begin BlendMemEx(Color, Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; EMMS; end; function Color32FloatPoint(Color: TColor32; Point: TFloatPoint): TColor32FloatPoint; begin Result.Point := Point; Result.Color32 := Color; end; function Color32FloatPoint(Color: TColor32; X, Y: TFloat): TColor32FloatPoint; begin Result.Point := FloatPoint(X, Y); Result.Color32 := Color; end; function Color32GradientStop(Offset: TFloat; Color: TColor32): TColor32GradientStop; begin Result.Offset := Offset; Result.Color32 := Color; end; type TLinear3PointInterpolation = function (A, B, C: TColor32; WA, WB, WC: Single): TColor32; TLinear4PointInterpolation = function (A, B, C, D: TColor32; WA, WB, WC, WD: Single): TColor32; { Linear interpolation of several (3, 4) colors } var Linear3PointInterpolationProc: TLinear3PointInterpolation; Linear4PointInterpolationProc: TLinear4PointInterpolation; function Linear3PointInterpolation_Pas(A, B, C: TColor32; WA, WB, WC: Single): TColor32; var Clr: TColor32Entry absolute Result; begin Clr.B := Clamp(Round( WA * TColor32Entry(A).B + WB * TColor32Entry(B).B + WC * TColor32Entry(C).B)); Clr.G := Clamp(Round( WA * TColor32Entry(A).G + WB * TColor32Entry(B).G + WC * TColor32Entry(C).G)); Clr.R := Clamp(Round( WA * TColor32Entry(A).R + WB * TColor32Entry(B).R + WC * TColor32Entry(C).R)); Clr.A := Clamp(Round( WA * TColor32Entry(A).A + WB * TColor32Entry(B).A + WC * TColor32Entry(C).A)); end; function Linear4PointInterpolation_Pas(A, B, C, D: TColor32; WA, WB, WC, WD: Single): TColor32; var Clr: TColor32Entry absolute Result; begin Clr.B := Clamp(Round( WA * TColor32Entry(A).B + WB * TColor32Entry(B).B + WC * TColor32Entry(C).B + WD * TColor32Entry(D).B)); Clr.G := Clamp(Round( WA * TColor32Entry(A).G + WB * TColor32Entry(B).G + WC * TColor32Entry(C).G + WD * TColor32Entry(D).G)); Clr.R := Clamp(Round( WA * TColor32Entry(A).R + WB * TColor32Entry(B).R + WC * TColor32Entry(C).R + WD * TColor32Entry(D).R)); Clr.A := Clamp(Round( WA * TColor32Entry(A).A + WB * TColor32Entry(B).A + WC * TColor32Entry(C).A + WD * TColor32Entry(D).A)); end; {$IFNDEF OMIT_SSE2} {$IFNDEF PUREPASCAL} function Linear3PointInterpolation_SSE2(A, B, C: TColor32; WA, WB, WC: Single): TColor32; asm {$IFDEF TARGET_X86} PXOR XMM3,XMM3 MOVD XMM0,EAX PUNPCKLBW XMM0,XMM3 PUNPCKLWD XMM0,XMM3 CVTDQ2PS XMM0,XMM0 MOVD XMM1,EDX PUNPCKLBW XMM1,XMM3 PUNPCKLWD XMM1,XMM3 CVTDQ2PS XMM1,XMM1 MOVD XMM2,ECX PUNPCKLBW XMM2,XMM3 PUNPCKLWD XMM2,XMM3 CVTDQ2PS XMM2,XMM2 MOV EAX, WA MOV EDX, WB MOV ECX, WC MOVD XMM4,EAX SHUFPS XMM4,XMM4,0 MOVD XMM5,EDX SHUFPS XMM5,XMM5,0 MOVD XMM6,ECX SHUFPS XMM6,XMM6,0 MULPS XMM0,XMM4 MULPS XMM1,XMM5 MULPS XMM2,XMM6 ADDPS XMM0,XMM1 ADDPS XMM0,XMM2 CVTPS2DQ XMM0,XMM0 PACKSSDW XMM0,XMM3 PACKUSWB XMM0,XMM3 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} MOVQ XMM0,XMM3 SHUFPS XMM0,XMM0,0 MOVD XMM1,WB SHUFPS XMM1,XMM1,0 MOVD XMM2,WC SHUFPS XMM2,XMM2,0 PXOR XMM3,XMM3 MOVD XMM4,ECX PUNPCKLBW XMM4,XMM3 PUNPCKLWD XMM4,XMM3 CVTDQ2PS XMM4,XMM4 MOVD XMM5,EDX PUNPCKLBW XMM5,XMM3 PUNPCKLWD XMM5,XMM3 CVTDQ2PS XMM5,XMM5 MOVD XMM6,R8D PUNPCKLBW XMM6,XMM3 PUNPCKLWD XMM6,XMM3 CVTDQ2PS XMM6,XMM6 MULPS XMM0,XMM4 MULPS XMM1,XMM5 MULPS XMM2,XMM6 ADDPS XMM0,XMM1 ADDPS XMM0,XMM2 CVTPS2DQ XMM0,XMM0 PACKSSDW XMM0,XMM3 PACKUSWB XMM0,XMM3 MOVD EAX,XMM0 {$ENDIF} end; function Linear4PointInterpolation_SSE2(A, B, C, D: TColor32; WA, WB, WC, WD: Single): TColor32; asm {$IFDEF TARGET_X86} PXOR XMM7,XMM7 MOVD XMM0,EAX PUNPCKLBW XMM0,XMM7 PUNPCKLWD XMM0,XMM7 CVTDQ2PS XMM0,XMM0 MOVD XMM1,EDX PUNPCKLBW XMM1,XMM7 PUNPCKLWD XMM1,XMM7 CVTDQ2PS XMM1,XMM1 MOV EAX, WA MOVD XMM4,EAX SHUFPS XMM4,XMM4,0 MULPS XMM0,XMM4 MOV EDX, WB MOVD XMM5,EDX SHUFPS XMM5,XMM5,0 MULPS XMM1,XMM5 ADDPS XMM0,XMM1 MOVD XMM2,ECX PUNPCKLBW XMM2,XMM7 PUNPCKLWD XMM2,XMM7 CVTDQ2PS XMM2,XMM2 MOVD XMM3,D PUNPCKLBW XMM3,XMM7 PUNPCKLWD XMM3,XMM7 CVTDQ2PS XMM3,XMM3 MOV EAX, WC MOVD XMM4,EAX SHUFPS XMM4,XMM4,0 MULPS XMM2,XMM4 MOV EDX, WD MOVD XMM5,EDX SHUFPS XMM5,XMM5,0 MULPS XMM3,XMM5 ADDPS XMM2,XMM3 ADDPS XMM0,XMM2 CVTPS2DQ XMM0,XMM0 PACKSSDW XMM0,XMM7 PACKUSWB XMM0,XMM7 MOVD EAX,XMM0 {$ENDIF} {$IFDEF TARGET_X64} PXOR XMM7,XMM7 MOVD XMM0,A PUNPCKLBW XMM0,XMM7 PUNPCKLWD XMM0,XMM7 CVTDQ2PS XMM0,XMM0 MOVD XMM1,B PUNPCKLBW XMM1,XMM7 PUNPCKLWD XMM1,XMM7 CVTDQ2PS XMM1,XMM1 MOV EAX, WA MOVD XMM4,EAX SHUFPS XMM4,XMM4,0 MULPS XMM0,XMM4 MOV EDX, WB MOVD XMM5,EDX SHUFPS XMM5,XMM5,0 MULPS XMM1,XMM5 ADDPS XMM0,XMM1 MOVD XMM2,C PUNPCKLBW XMM2,XMM7 PUNPCKLWD XMM2,XMM7 CVTDQ2PS XMM2,XMM2 MOVD XMM3,D PUNPCKLBW XMM3,XMM7 PUNPCKLWD XMM3,XMM7 CVTDQ2PS XMM3,XMM3 MOV EAX, WC MOVD XMM4,EAX SHUFPS XMM4,XMM4,0 MULPS XMM2,XMM4 MOV EDX, WD MOVD XMM5,EDX SHUFPS XMM5,XMM5,0 MULPS XMM3,XMM5 ADDPS XMM2,XMM3 ADDPS XMM0,XMM2 CVTPS2DQ XMM0,XMM0 PACKSSDW XMM0,XMM7 PACKUSWB XMM0,XMM7 MOVD EAX,XMM0 {$ENDIF} end; {$ENDIF} {$ENDIF} { TColor32LookupTable } constructor TColor32LookupTable.Create(Order: Byte); begin inherited Create; FOrder := Order; OrderChanged; end; destructor TColor32LookupTable.Destroy; begin {$WARNINGS OFF} FreeMem(FGradientLUT); {$WARNINGS ON} inherited; end; procedure TColor32LookupTable.AssignTo(Dest: TPersistent); begin if Dest is TColor32LookupTable then with TColor32LookupTable(Dest) do begin FOrder := Self.FOrder; OrderChanged; Move(Self.FGradientLUT^, FGradientLUT^, FSize * SizeOf(TColor32)); end else inherited; end; function TColor32LookupTable.GetColor32(Index: Integer): TColor32; begin Result := FGradientLUT^[Index and FMask]; end; procedure TColor32LookupTable.OrderChanged; begin FSize := 1 shl FOrder; FMask := FSize - 1; {$WARNINGS OFF} ReallocMem(FGradientLUT, FSize * SizeOf(TColor32)); {$WARNINGS ON} if Assigned(FOnOrderChanged) then FOnOrderChanged(Self); end; procedure TColor32LookupTable.SetColor32(Index: Integer; const Value: TColor32); begin if (Index < 0) or (Index > Integer(FMask)) then raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]) else FGradientLUT^[Index] := Value; end; procedure TColor32LookupTable.SetOrder(const Value: Byte); begin if FOrder <> Value then begin FOrder := Value; OrderChanged; end; end; { TColor32Gradient; } constructor TColor32Gradient.Create(Color: TColor32); begin Create(Color, Color); end; constructor TColor32Gradient.Create(StartColor, EndColor: TColor32); var Temp: TArrayOfColor32GradientStop; begin // simple gradient using 2 color stops SetLength(Temp, 2); Temp[0].Offset := 0; Temp[0].Color32 := StartColor; Temp[1].Offset := 1; Temp[1].Color32 := EndColor; Create(Temp); end; constructor TColor32Gradient.Create(const GradientColors: TArrayOfColor32GradientStop); begin inherited Create; SetColors(GradientColors); end; procedure TColor32Gradient.AssignTo(Dest: TPersistent); begin if Dest is TColor32Gradient then TColor32Gradient(Dest).SetColors(Self.FGradientColors) else inherited; end; procedure TColor32Gradient.AddColorStop(ColorStop: TColor32GradientStop); begin AddColorStop(ColorStop.Offset, ColorStop.Color32); end; procedure TColor32Gradient.AddColorStop(Offset: TFloat; Color: TColor32); var Index, OldCount: Integer; begin OldCount := Length(FGradientColors); Index := 0; // navigate to index where the color stop shall be inserted while (Index < OldCount) and (Offset >= FGradientColors[Index].Offset) do Inc(Index); SetLength(FGradientColors, OldCount + 1); // move existing color stops to make space for the new color stop if (Index < OldCount) then Move(FGradientColors[Index], FGradientColors[Index + 1], (OldCount - Index) * SizeOf(TColor32GradientStop)); // finally insert new color stop FGradientColors[Index].Offset := Offset; FGradientColors[Index].Color32 := Color; GradientColorsChanged; end; procedure TColor32Gradient.ClearColorStops(Color: TColor32); begin SetLength(FGradientColors, 0); FGradientColors[0].Offset := 0; FGradientColors[0].Color32 := Color; GradientColorsChanged; end; procedure TColor32Gradient.ClearColorStops; begin SetLength(FGradientColors, 0); GradientColorsChanged; end; procedure TColor32Gradient.SetColors(const GradientColors: array of const); var Index: Integer; Scale: TFloat; begin if High(GradientColors) < 0 then begin // no colors specified if Length(FGradientColors) > 0 then ClearColorStops; end else begin SetLength(FGradientColors, High(GradientColors) + 1); if High(GradientColors) >= 1 then begin // several colors (at least 2) Scale := 1 / (Length(GradientColors) - 1); for Index := 0 to Length(GradientColors) - 1 do begin Assert(GradientColors[Index].VType = vtInteger); FGradientColors[Index].Color32 := GradientColors[Index].VInteger; FGradientColors[Index].Offset := Index * Scale; end; end else begin // only 1 color Assert(GradientColors[0].VType = vtInteger); FGradientColors[0].Color32 := GradientColors[0].VInteger; FGradientColors[0].Offset := 0; end; GradientColorsChanged; end; end; procedure TColor32Gradient.SetColors(const GradientColors: TArrayOfColor32GradientStop); var Index: Integer; begin if Length(GradientColors) = 0 then begin if Length(FGradientColors) > 0 then ClearColorStops; end else begin SetLength(FGradientColors, Length(GradientColors)); for Index := 0 to Length(GradientColors) - 1 do FGradientColors[Index] := GradientColors[Index]; GradientColorsChanged; end; end; procedure TColor32Gradient.SetColors(const GradientColors: TArrayOfColor32); var Index: Integer; Scale: TFloat; begin if Length(GradientColors) = 0 then begin // no colors specified if Length(FGradientColors) > 0 then ClearColorStops; end else begin SetLength(FGradientColors, Length(GradientColors)); if Length(GradientColors) > 1 then begin // several colors (at least 2) Scale := 1 / (Length(GradientColors) - 1); for Index := 0 to Length(GradientColors) - 1 do begin FGradientColors[Index].Color32 := GradientColors[Index]; FGradientColors[Index].Offset := Index * Scale; end; end else begin // only 1 color FGradientColors[0].Color32 := GradientColors[0]; FGradientColors[0].Offset := 0; end; GradientColorsChanged; end; end; procedure TColor32Gradient.SetColors(const Palette: TPalette32); var Index: Integer; Scale: TFloat; begin // TPalette32 contains 256 colors SetLength(FGradientColors, Length(Palette)); Scale := 1 / (Length(Palette) - 1); for Index := 0 to Length(Palette) - 1 do begin FGradientColors[Index].Color32 := Palette[Index]; FGradientColors[Index].Offset := Index * Scale; end; GradientColorsChanged; end; procedure TColor32Gradient.SetStartColor(const Value: TColor32); var HasChanged: Boolean; begin HasChanged := False; if Length(FGradientColors) = 0 then begin SetLength(FGradientColors, 1); HasChanged := True; end; if FGradientColors[0].Offset <> 0 then begin FGradientColors[0].Offset := 0; HasChanged := True; end; if FGradientColors[0].Color32 <> Value then begin FGradientColors[0].Color32 := Value; HasChanged := True; end; if HasChanged then GradientColorsChanged; end; procedure TColor32Gradient.SetEndColor(const Value: TColor32); var HasChanged: Boolean; begin HasChanged := False; if Length(FGradientColors) = 1 then begin SetLength(FGradientColors, 2); HasChanged := True; end; if FGradientColors[High(FGradientColors)].Offset <> 1 then begin FGradientColors[High(FGradientColors)].Offset := 1; HasChanged := True; end; if FGradientColors[High(FGradientColors)].Color32 <> Value then begin FGradientColors[High(FGradientColors)].Color32 := Value; HasChanged := True; end; if HasChanged then GradientColorsChanged; end; function TColor32Gradient.GetGradientCount: Integer; begin Result := Length(FGradientColors); end; function TColor32Gradient.GetGradientEntry(Index: Integer): TColor32GradientStop; begin if Index > Length(FGradientColors) then raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]) else Result := FGradientColors[Index]; end; function TColor32Gradient.GetStartColor: TColor32; begin if Length(FGradientColors) = 0 then Result := clNone32 else Result := FGradientColors[0].Color32; end; function TColor32Gradient.GetEndColor: TColor32; var Count: Integer; begin Count := Length(FGradientColors); if Count = 0 then Result := clNone32 else Result := FGradientColors[Count - 1].Color32; end; function TColor32Gradient.GetColorAt(Offset: TFloat): TColor32; var Index, Count: Integer; begin Count := GradientCount; if (Count = 0) or (Offset <= FGradientColors[0].Offset) then Result := StartColor else if (Offset >= FGradientColors[Count - 1].Offset) then Result := EndColor else begin Index := 1; // find color index for a given offset (between 0 and 1) while (Index < Count) and (Offset > FGradientColors[Index].Offset) do Inc(Index); // calculate new offset (between two colors before and at 'Index') Offset := (Offset - FGradientColors[Index - 1].Offset) / (FGradientColors[Index].Offset - FGradientColors[Index - 1].Offset); // check if offset is out of bounds if Offset <= 0 then Result := FGradientColors[Index - 1].Color32 else if Offset >= 1 then Result := FGradientColors[Index].Color32 else begin // interpolate color Result := CombineReg(FGradientColors[Index].Color32, FGradientColors[Index - 1].Color32, Round($FF * Offset)); EMMS; end; end; end; procedure TColor32Gradient.FillColorLookUpTable(ColorLUT: TColor32LookupTable); begin FillColorLookUpTable(ColorLUT.Color32Ptr, ColorLUT.Size); end; procedure TColor32Gradient.FillColorLookUpTable(var ColorLUT: array of TColor32); begin {$WARNINGS OFF} FillColorLookUpTable(@ColorLUT[0], Length(ColorLUT)); {$WARNINGS ON} end; procedure TColor32Gradient.FillColorLookUpTable(ColorLUT: PColor32Array; Count: Integer); var LutIndex, StopIndex, GradCount: Integer; RecalculateScale: Boolean; Fraction, LocalFraction, Delta, Scale: TFloat; begin GradCount := GradientCount; //check trivial case if (GradCount < 2) or (Count < 2) then begin for LutIndex := 0 to Count - 1 do ColorLUT^[LutIndex] := StartColor; Exit; end; // set first (start) and last (end) color ColorLUT^[0] := StartColor; ColorLUT^[Count - 1] := EndColor; Delta := 1 / Count; Fraction := Delta; LutIndex := 1; while Fraction <= FGradientColors[0].Offset do begin ColorLUT^[LutIndex] := ColorLUT^[0]; Fraction := Fraction + Delta; Inc(LutIndex); end; Scale := 1; StopIndex := 1; RecalculateScale := True; for LutIndex := LutIndex to Count - 2 do begin // eventually search next stop while (Fraction > FGradientColors[StopIndex].Offset) do begin Inc(StopIndex); if (StopIndex >= GradCount) then Break; RecalculateScale := True; end; // eventually fill remaining LUT if StopIndex = GradCount then begin for StopIndex := LutIndex to Count - 2 do ColorLUT^[StopIndex] := ColorLUT^[Count - 1]; Break; end; // eventually recalculate scale if RecalculateScale then Scale := 1 / (FGradientColors[StopIndex].Offset - FGradientColors[StopIndex - 1].Offset); // calculate current color LocalFraction := (Fraction - FGradientColors[StopIndex - 1].Offset) * Scale; if LocalFraction <= 0 then ColorLUT^[LutIndex] := FGradientColors[StopIndex - 1].Color32 else if LocalFraction >= 1 then ColorLUT^[LutIndex] := FGradientColors[StopIndex].Color32 else begin ColorLUT^[LutIndex] := CombineReg(FGradientColors[StopIndex].Color32, FGradientColors[StopIndex - 1].Color32, Round($FF * LocalFraction)); EMMS; end; Fraction := Fraction + Delta; end; end; procedure TColor32Gradient.GradientColorsChanged; begin if Assigned(FOnGradientColorsChanged) then FOnGradientColorsChanged(Self); end; procedure TColor32Gradient.LoadFromStream(Stream: TStream); var Index: Integer; ChunkName: array [0..3] of AnsiChar; ValueInt: Integer; ValueFloat: Single; begin // read simple header Stream.Read(ChunkName, 4); if ChunkName <> 'Grad' then raise Exception.Create(RCStrWrongFormat); Stream.Read(ValueInt, 4); SetLength(FGradientColors, ValueInt); // read data for Index := 0 to Length(FGradientColors) - 1 do begin ValueFloat := FGradientColors[Index].Offset; Stream.Read(ValueFloat, 4); ValueInt := FGradientColors[Index].Color32; Stream.Read(ValueInt, 4); end; GradientColorsChanged; end; procedure TColor32Gradient.SaveToStream(Stream: TStream); var Index: Integer; ChunkName: array [0..3] of AnsiChar; ValueInt: Integer; ValueFloat: Single; begin // write simple header ChunkName := 'Grad'; Stream.Write(ChunkName, 4); ValueInt := Length(FGradientColors); Stream.Write(ValueInt, 4); // write data for Index := 0 to Length(FGradientColors) - 1 do begin ValueFloat := FGradientColors[Index].Offset; Stream.Write(ValueFloat, 4); ValueInt := FGradientColors[Index].Color32; Stream.Write(ValueInt, 4); end; end; { TCustomSparsePointGradientSampler } function TCustomSparsePointGradientSampler.GetSampleFixed(X, Y: TFixed): TColor32; begin Result := GetSampleFloat(X * FixedToFloat, Y * FixedToFloat); end; function TCustomSparsePointGradientSampler.GetSampleInt(X, Y: Integer): TColor32; begin Result := GetSampleFloat(X, Y); end; { TBarycentricGradientSampler } constructor TBarycentricGradientSampler.Create(P1, P2, P3: TColor32FloatPoint); begin FColorPoints[0] := P1; FColorPoints[1] := P2; FColorPoints[2] := P3; inherited Create; end; procedure TBarycentricGradientSampler.AssignTo(Dest: TPersistent); begin if Dest is TBarycentricGradientSampler then with TBarycentricGradientSampler(Dest) do FColorPoints := Self.FColorPoints else inherited; end; function TBarycentricGradientSampler.GetColor(Index: Integer): TColor32; begin if Index in [0 .. 2] then Result := FColorPoints[Index].Color32 else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TBarycentricGradientSampler.GetColorPoint( Index: Integer): TColor32FloatPoint; begin if Index in [0 .. 2] then Result := FColorPoints[Index] else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TBarycentricGradientSampler.GetCount: Integer; begin Result := 3; end; function TBarycentricGradientSampler.GetPoint(Index: Integer): TFloatPoint; begin if Index in [0 .. 2] then Result := FColorPoints[Index].Point else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TBarycentricGradientSampler.CalculateBarycentricCoordinates( X, Y: TFloat; out U, V, W: TFloat); var Temp: TFloatPoint; begin Temp.X := X - FColorPoints[2].Point.X; Temp.Y := Y - FColorPoints[2].Point.Y; U := FDists[0].Y * Temp.X + FDists[0].X * Temp.Y; V := FDists[1].Y * Temp.X + FDists[1].X * Temp.Y; W := 1 - U - V; end; function TBarycentricGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32; var U, V, W: TFloat; begin CalculateBarycentricCoordinates(X, Y, U, V, W); Result := Linear3PointInterpolationProc(FColorPoints[0].Color32, FColorPoints[1].Color32, FColorPoints[2].Color32, U, V, W); end; function TBarycentricGradientSampler.GetSampleFloatInTriangle(X, Y: TFloat): TColor32; var U, V, W: TFloat; begin CalculateBarycentricCoordinates(X, Y, U, V, W); if U < 0 then begin U := (V + W); V := V / U; W := W / U; U := 0; end; if V < 0 then begin V := (U + W); U := U / V; W := W / V; V := 0; end; if V < 0 then begin W := (U + V); U := U / W; V := V / W; W := 0; end; Result := Linear3PointInterpolationProc(FColorPoints[0].Color32, FColorPoints[1].Color32, FColorPoints[2].Color32, U, V, W); end; function TBarycentricGradientSampler.IsPointInTriangle( const Point: TFloatPoint): Boolean; var U, V, W: TFloat; begin CalculateBarycentricCoordinates(Point.X, Point.Y, U, V, W); Result := (U >= 0) and (V >= 0) and (W >= 0); end; function TBarycentricGradientSampler.IsPointInTriangle(X, Y: TFloat): Boolean; var U, V, W: TFloat; begin CalculateBarycentricCoordinates(X, Y, U, V, W); Result := (U >= 0) and (V >= 0) and (W >= 0); end; procedure TBarycentricGradientSampler.PrepareSampling; var NormScale: TFloat; begin NormScale := 1 / ((FColorPoints[1].Point.Y - FColorPoints[2].Point.Y) * (FColorPoints[0].Point.X - FColorPoints[2].Point.X) + (FColorPoints[2].Point.X - FColorPoints[1].Point.X) * (FColorPoints[0].Point.Y - FColorPoints[2].Point.Y)); FDists[0].X := NormScale * (FColorPoints[2].Point.X - FColorPoints[1].Point.X); FDists[0].Y := NormScale * (FColorPoints[1].Point.Y - FColorPoints[2].Point.Y); FDists[1].X := NormScale * (FColorPoints[0].Point.X - FColorPoints[2].Point.X); FDists[1].Y := NormScale * (FColorPoints[2].Point.Y - FColorPoints[0].Point.Y); end; procedure TBarycentricGradientSampler.SetColor(Index: Integer; const Value: TColor32); begin if Index in [0 .. 2] then FColorPoints[Index].Color32 := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TBarycentricGradientSampler.SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); begin if Index in [0 .. 2] then FColorPoints[Index] := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TBarycentricGradientSampler.SetColorPoints( ColorPoints: TArrayOfColor32FloatPoint); begin if Length(ColorPoints) <> 3 then raise Exception.Create(RCStrOnlyExactly3Point); FColorPoints[0] := ColorPoints[0]; FColorPoints[1] := ColorPoints[1]; FColorPoints[2] := ColorPoints[2]; end; procedure TBarycentricGradientSampler.SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); begin if (Length(Points) <> 3) or (Length(Colors) <> 3) then raise Exception.Create(RCStrOnlyExactly3Point); FColorPoints[0] := Color32FloatPoint(Colors[0], Points[0]); FColorPoints[1] := Color32FloatPoint(Colors[1], Points[1]); FColorPoints[2] := Color32FloatPoint(Colors[2], Points[2]); end; procedure TBarycentricGradientSampler.SetPoint(Index: Integer; const Value: TFloatPoint); begin if Index in [0 .. 2] then FColorPoints[Index].Point := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TBarycentricGradientSampler.SetPoints(Points: TArrayOfFloatPoint); begin if Length(Points) <> 3 then raise Exception.Create(RCStrOnlyExactly3Point); FColorPoints[0].Point := Points[0]; FColorPoints[1].Point := Points[1]; FColorPoints[2].Point := Points[2]; end; { TBilinearGradientSampler } procedure TBilinearGradientSampler.AssignTo(Dest: TPersistent); begin if Dest is TBilinearGradientSampler then with TBilinearGradientSampler(Dest) do FColorPoints := Self.FColorPoints else inherited; end; function TBilinearGradientSampler.GetColor(Index: Integer): TColor32; begin if Index in [0 .. 3] then Result := FColorPoints[Index].Color32 else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TBilinearGradientSampler.GetColorPoint( Index: Integer): TColor32FloatPoint; begin if Index in [0 .. 3] then Result := FColorPoints[Index] else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TBilinearGradientSampler.GetCount: Integer; begin Result := 4; end; function TBilinearGradientSampler.GetPoint(Index: Integer): TFloatPoint; begin if Index in [0 .. 3] then Result := FColorPoints[Index].Point else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TBilinearGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32; var u, v, t, k0, k1: Double; begin k1 := FDot + X * FDists[2].Y - Y * FDists[2].X; k0 := FBiasK0 + X * FDists[0].Y - Y * FDists[0].X; t := Sqr(k1) - 2 * k0 * FK2Value; if FK2Value = 0 then v := -k0 / k1 else v := (FK2Sign * Sqrt(Abs(t)) - k1) / FK2Value; u := (X - FBiasU - FDists[1].X * v) / (FDists[0].X + FDists[2].X * v); Result := Linear4PointInterpolationProc(FColorPoints[0].Color32, FColorPoints[1].Color32, FColorPoints[2].Color32, FColorPoints[3].Color32, (1 - u) * (1 - v), u * (1 - v), u * v, (1 - u) * v); end; procedure TBilinearGradientSampler.PrepareSampling; var v, i, j: Integer; Orientation: array [0 .. 3] of Boolean; Indices: array [0 .. 1] of Integer; TempPoint: TColor32FloatPoint; begin Orientation[0] := (FColorPoints[0].Point.X - FColorPoints[3].Point.X) * (FColorPoints[1].Point.Y - FColorPoints[0].Point.Y) - (FColorPoints[0].Point.Y - FColorPoints[3].Point.Y) * (FColorPoints[1].Point.X - FColorPoints[0].Point.X) < 0; Orientation[1] := (FColorPoints[1].Point.X - FColorPoints[0].Point.X) * (FColorPoints[2].Point.Y - FColorPoints[1].Point.Y) - (FColorPoints[1].Point.Y - FColorPoints[0].Point.Y) * (FColorPoints[2].Point.X - FColorPoints[1].Point.X) < 0; Orientation[2] := (FColorPoints[2].Point.X - FColorPoints[1].Point.X) * (FColorPoints[3].Point.Y - FColorPoints[2].Point.Y) - (FColorPoints[2].Point.Y - FColorPoints[1].Point.Y) * (FColorPoints[3].Point.X - FColorPoints[2].Point.X) < 0; Orientation[3] := (FColorPoints[3].Point.X - FColorPoints[2].Point.X) * (FColorPoints[0].Point.Y - FColorPoints[3].Point.Y) - (FColorPoints[3].Point.Y - FColorPoints[2].Point.Y) * (FColorPoints[0].Point.X - FColorPoints[3].Point.X) < 0; if Orientation[0] then v := -1 else v := 1; if Orientation[1] then Dec(v) else Inc(v); if Orientation[2] then Dec(v) else Inc(v); if Orientation[3] then Dec(v) else Inc(v); FK2Sign := Sign(v); if v = 0 then begin // correct complex case i := 0; j := 0; repeat if Orientation[j] then begin Indices[i] := j; Inc(i); end; Inc(j); until i = 2; // exchange color points TempPoint := FColorPoints[Indices[0]]; FColorPoints[Indices[0]] := FColorPoints[Indices[1]]; FColorPoints[Indices[1]] := TempPoint; FK2Sign := 1; end; FDists[0].X := FColorPoints[1].Point.X - FColorPoints[0].Point.X; FDists[0].Y := FColorPoints[1].Point.Y - FColorPoints[0].Point.Y; FDists[1].X := FColorPoints[3].Point.X - FColorPoints[0].Point.X; FDists[1].Y := FColorPoints[3].Point.Y - FColorPoints[0].Point.Y; FDists[2].X := FColorPoints[0].Point.X - FColorPoints[1].Point.X + FColorPoints[2].Point.X - FColorPoints[3].Point.X; FDists[2].Y := FColorPoints[0].Point.Y - FColorPoints[1].Point.Y + FColorPoints[2].Point.Y - FColorPoints[3].Point.Y; FK2Value := 2 * (FDists[2].X * FDists[1].Y - FDists[2].Y * FDists[1].X); FDot := FDists[0].X * FDists[1].Y - FDists[0].Y * FDists[1].X - FColorPoints[0].Point.X * FDists[2].Y + FColorPoints[0].Point.Y * FDists[2].X; FBiasK0 := FColorPoints[0].Point.Y * FDists[0].X - FColorPoints[0].Point.X * FDists[0].Y; FBiasU := FColorPoints[0].Point.X; end; procedure TBilinearGradientSampler.SetColor(Index: Integer; const Value: TColor32); begin if Index in [0 .. 3] then FColorPoints[Index].Color32 := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TBilinearGradientSampler.SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); begin if Index in [0 .. 3] then FColorPoints[Index] := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TBilinearGradientSampler.SetColorPoints( ColorPoints: TArrayOfColor32FloatPoint); begin if Length(ColorPoints) <> 4 then raise Exception.Create(RCStrOnlyExactly3Point); FColorPoints[0] := ColorPoints[0]; FColorPoints[1] := ColorPoints[1]; FColorPoints[2] := ColorPoints[2]; FColorPoints[3] := ColorPoints[3]; end; procedure TBilinearGradientSampler.SetColorPoints(Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); begin if (Length(Points) <> 3) or (Length(Colors) <> 3) then raise Exception.Create(RCStrOnlyExactly3Point); FColorPoints[0] := Color32FloatPoint(Colors[0], Points[0]); FColorPoints[1] := Color32FloatPoint(Colors[1], Points[1]); FColorPoints[2] := Color32FloatPoint(Colors[2], Points[2]); FColorPoints[3] := Color32FloatPoint(Colors[3], Points[3]); end; procedure TBilinearGradientSampler.SetPoint(Index: Integer; const Value: TFloatPoint); begin if Index in [0 .. 3] then FColorPoints[Index].Point := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TBilinearGradientSampler.SetPoints(Points: TArrayOfFloatPoint); begin if Length(Points) <> 4 then raise Exception.Create(RCStrOnlyExactly3Point); FColorPoints[0].Point := Points[0]; FColorPoints[1].Point := Points[1]; FColorPoints[2].Point := Points[2]; FColorPoints[3].Point := Points[3]; end; { TCustomArbitrarySparsePointGradientSampler } procedure TCustomArbitrarySparsePointGradientSampler.AssignTo(Dest: TPersistent); begin if Dest is TCustomArbitrarySparsePointGradientSampler then with TCustomArbitrarySparsePointGradientSampler(Dest) do begin FColorPoints := Self.FColorPoints; end else inherited; end; procedure TCustomArbitrarySparsePointGradientSampler.Add(Point: TFloatPoint; Color: TColor32); var Index: Integer; begin Index := Length(FColorPoints); SetLength(FColorPoints, Index + 1); FColorPoints[Index].Point := Point; FColorPoints[Index].Color32 := Color; end; procedure TCustomArbitrarySparsePointGradientSampler.Add( const ColorPoint: TColor32FloatPoint); var Index: Integer; begin Index := Length(FColorPoints); SetLength(FColorPoints, Index + 1); FColorPoints[Index].Point := ColorPoint.Point; FColorPoints[Index].Color32 := ColorPoint.Color32; end; procedure TCustomArbitrarySparsePointGradientSampler.Clear; begin SetLength(FColorPoints, 0); end; function TCustomArbitrarySparsePointGradientSampler.GetColor( Index: Integer): TColor32; begin if (Index >= 0) and (Index < Length(FColorPoints)) then Result := FColorPoints[Index].Color32 else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TCustomArbitrarySparsePointGradientSampler.GetColorPoint( Index: Integer): TColor32FloatPoint; begin if (Index >= 0) and (Index < Length(FColorPoints)) then Result := FColorPoints[Index] else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TCustomArbitrarySparsePointGradientSampler.GetCount: Integer; begin Result := Length(FColorPoints); end; function TCustomArbitrarySparsePointGradientSampler.GetPoint( Index: Integer): TFloatPoint; begin if (Index >= 0) and (Index < Length(FColorPoints)) then Result := FColorPoints[Index].Point else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TCustomArbitrarySparsePointGradientSampler.SetColor(Index: Integer; const Value: TColor32); begin if (Index >= 0) and (Index < Length(FColorPoints)) then FColorPoints[Index].Color32 := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TCustomArbitrarySparsePointGradientSampler.SetColorPoint( Index: Integer; const Value: TColor32FloatPoint); begin if (Index >= 0) and (Index < Length(FColorPoints)) then FColorPoints[Index] := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TCustomArbitrarySparsePointGradientSampler.SetPoint(Index: Integer; const Value: TFloatPoint); begin if (Index >= 0) and (Index < Length(FColorPoints)) then FColorPoints[Index].Point := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TCustomArbitrarySparsePointGradientSampler.SetColorPoints( ColorPoints: TArrayOfColor32FloatPoint); var Index: Integer; begin SetLength(FColorPoints, Length(ColorPoints)); for Index := 0 to High(FColorPoints) do FColorPoints[Index] := ColorPoints[Index]; end; procedure TCustomArbitrarySparsePointGradientSampler.SetColorPoints( Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); var Index: Integer; begin if Length(Points) <> Length(Colors) then raise Exception.Create(RCStrPointCountMismatch); SetLength(FColorPoints, Length(Points)); for Index := 0 to High(FColorPoints) do begin FColorPoints[Index].Point := Points[Index]; FColorPoints[Index].Color32 := Colors[Index]; end; end; procedure TCustomArbitrarySparsePointGradientSampler.SetPoints( Points: TArrayOfFloatPoint); var Index: Integer; begin if Length(FColorPoints) <> Length(Points) then raise Exception.Create(RCStrPointCountMismatch); for Index := 0 to High(Points) do FColorPoints[Index].Point := Points[Index]; end; { TInvertedDistanceWeightingSampler } constructor TInvertedDistanceWeightingSampler.Create; begin inherited; FPower := 2; FScaledPower := 0.5 * FPower; end; procedure TInvertedDistanceWeightingSampler.FinalizeSampling; begin inherited; Finalize(FDists); end; function TInvertedDistanceWeightingSampler.GetSampleFloat(X, Y: TFloat): TColor32; var Index: Integer; Temp, DistSum, Scale: Double; R, G, B, A: TFloat; begin if Count = 1 then begin Result := FColorPoints[0].Color32; Exit; end; with FColorPoints[0] do Temp := Sqr(X - Point.X) + Sqr(Y - Point.Y); if FUsePower then Temp := Math.Power(Temp, FScaledPower); FDists[0] := 1 / Max(1, Temp); DistSum := FDists[0]; for Index := 1 to Count - 1 do with FColorPoints[Index] do begin Temp := Sqr(X - Point.X) + Sqr(Y - Point.Y); if FUsePower then Temp := Math.Power(Temp, FScaledPower); FDists[Index] := 1 / Max(1, Temp); DistSum := DistSum + FDists[Index]; end; Assert(DistSum <> 0); DistSum := 1 / DistSum; Scale := FDists[0] * DistSum; case Count of 3: begin // optimization for 3-Point interpolation Result := Linear3PointInterpolationProc(FColorPoints[0].Color32, FColorPoints[1].Color32, FColorPoints[2].Color32, FDists[0] * DistSum, FDists[1] * DistSum, FDists[2] * DistSum); Exit; end; 4: begin // optimization for 4-Point interpolation Result := Linear4PointInterpolationProc(FColorPoints[0].Color32, FColorPoints[1].Color32, FColorPoints[2].Color32, FColorPoints[3].Color32, FDists[0] * DistSum, FDists[1] * DistSum, FDists[2] * DistSum, FDists[3] * DistSum); Exit; end; end; // general n-Point interpolation R := Scale * TColor32Entry(FColorPoints[0].Color32).R; G := Scale * TColor32Entry(FColorPoints[0].Color32).G; B := Scale * TColor32Entry(FColorPoints[0].Color32).B; A := Scale * TColor32Entry(FColorPoints[0].Color32).A; for Index := 1 to Count - 1 do begin Scale := FDists[Index] * DistSum; R := R + Scale * TColor32Entry(FColorPoints[Index].Color32).R; G := G + Scale * TColor32Entry(FColorPoints[Index].Color32).G; B := B + Scale * TColor32Entry(FColorPoints[Index].Color32).B; A := A + Scale * TColor32Entry(FColorPoints[Index].Color32).A; end; Result := Color32(Clamp(Round(R)), Clamp(Round(G)), Clamp(Round(B)), Clamp(Round(A))); end; procedure TInvertedDistanceWeightingSampler.PrepareSampling; begin SetLength(FDists, Count); FUsePower := FPower <> 2; FScaledPower := 0.5 * FPower; inherited; end; { TVoronoiSampler } function TVoronoiSampler.GetSampleFloat(X, Y: TFloat): TColor32; var Index, NearestIndex: Integer; Distance: TFloat; NearestDistance: TFloat; begin NearestIndex := 0; NearestDistance := Sqr(X - FColorPoints[0].Point.X) + Sqr(Y - FColorPoints[0].Point.Y); for Index := 1 to High(FColorPoints) do begin Distance := Sqr(X - FColorPoints[Index].Point.X) + Sqr(Y - FColorPoints[Index].Point.Y); if Distance < NearestDistance then begin NearestDistance := Distance; NearestIndex := Index; end; end; Result := FColorPoints[NearestIndex].Color32; end; { TDelaunaySampler } procedure FastMergeSortX(const Values: TArrayOfColor32FloatPoint; out Indexes: TArrayOfInteger; out Bounds: TFloatRect); var Temp: TArrayOfInteger; procedure Merge(I1, I2, J1, J2: Integer); var I, J, K: Integer; begin if Values[Indexes[I2]].Point.X < Values[Indexes[J1]].Point.X then Exit; I := I1; J := J1; K := 0; repeat if Values[Indexes[I]].Point.X < Values[Indexes[J]].Point.X then begin Temp[K] := Indexes[I]; Inc(I); end else begin Temp[K] := Indexes[J]; Inc(J); end; Inc(K); until (I > I2) or (J > J2); while I <= I2 do begin Temp[K] := Indexes[I]; Inc(I); Inc(K); end; while J <= J2 do begin Temp[K] := Indexes[J]; Inc(J); Inc(K); end; for I := 0 to K - 1 do begin Indexes[I + I1] := Temp[I]; end; end; procedure Recurse(I1, I2: Integer); var I, IX: Integer; begin if I1 = I2 then Indexes[I1] := I1 else if Indexes[I1] = Indexes[I2] then begin if Values[I1].Point.X <= Values[I2].Point.X then begin for I := I1 to I2 do Indexes[I] := I; end else begin IX := I1 + I2; for I := I1 to I2 do Indexes[I] := IX - I; end; end else begin IX := (I1 + I2) div 2; Recurse(I1, IX); Recurse(IX + 1, I2); Merge(I1, IX, IX + 1, I2); end; end; var I, Index, S: Integer; begin SetLength(Temp, Length(Values)); SetLength(Indexes, Length(Values)); Index := 0; S := Math.Sign(Values[1].Point.X - Values[0].Point.X); if S = 0 then S := 1; Indexes[0] := 0; // initialize bounds Bounds.Left := Values[0].Point.X; Bounds.Top := Values[0].Point.Y; Bounds.Right := Bounds.Left; Bounds.Bottom := Bounds.Top; for I := 1 to High(Values) do begin if Math.Sign(Values[I].Point.X - Values[I - 1].Point.X) = -S then begin S := -S; Inc(Index); end; // determine bounds if Values[I].Point.X < Bounds.Left then Bounds.Left := Values[I].Point.X; if Values[I].Point.Y < Bounds.Top then Bounds.Top := Values[I].Point.Y; if Values[I].Point.X > Bounds.Right then Bounds.Right := Values[I].Point.X; if Values[I].Point.Y > Bounds.Bottom then Bounds.Bottom := Values[I].Point.Y; Indexes[I] := Index; end; Recurse(0, High(Values)); end; function DelaunayTriangulation(Points: TArrayOfColor32FloatPoint): TArrayOfTriangleVertexIndices; var Complete: array of Byte; Edges: array of array [0 .. 1] of Integer; ByteIndex, Bit: Byte; MaxVerticesCount, EdgeCount, MaxEdgeCount, MaxTriangleCount: Integer; // For super triangle ScaledDeltaMax: TFloat; Mid: TFloatPoint; Bounds: TFloatRect; // General Variables SortedVertexIndices: TArrayOfInteger; TriangleCount, VertexCount, I, J, K: Integer; CenterX, CenterY, RadSqr: TFloat; Inside: Boolean; const CSuperTriangleCount = 3; // -> super triangle CTolerance = 0.000001; function InCircle(Pt, Pt1, Pt2, Pt3: TFloatPoint): Boolean; // Return TRUE if the point Pt(x, y) lies inside the circumcircle made up by // points Pt1(x, y) Pt2(x, y) Pt3(x, y) // The circumcircle centre is returned in (CenterX, CenterY) and the radius r // NOTE: A point on the edge is inside the circumcircle var M1, M2, MX1, MY1, MX2, MY2: Double; DeltaX, DeltaY, DeltaRadSqr, AbsY1Y2, AbsY2Y3: Double; begin AbsY1Y2 := Abs(Pt1.Y - Pt2.Y); AbsY2Y3 := Abs(Pt2.Y - Pt3.Y); // check for coincident points if (AbsY1Y2 < CTolerance) and (AbsY2Y3 < CTolerance) then begin Result := False; Exit; end; if AbsY1Y2 < CTolerance then begin M2 := -(Pt3.X - Pt2.X) / (Pt3.Y - Pt2.Y); MX2 := (Pt2.X + Pt3.X) * 0.5; MY2 := (Pt2.Y + Pt3.Y) * 0.5; CenterX := (Pt2.X + Pt1.X) * 0.5; CenterY := M2 * (CenterX - MX2) + MY2; end else if AbsY2Y3 < CTolerance then begin M1 := -(Pt2.X - Pt1.X) / (Pt2.Y - Pt1.Y); MX1 := (Pt1.X + Pt2.X) * 0.5; MY1 := (Pt1.Y + Pt2.Y) * 0.5; CenterX := (Pt3.X + Pt2.X) * 0.5; CenterY := M1 * (CenterX - MX1) + MY1; end else begin M1 := -(Pt2.X - Pt1.X) / (Pt2.Y - Pt1.Y); M2 := -(Pt3.X - Pt2.X) / (Pt3.Y - Pt2.Y); if Abs(M1 - M2) < CTolerance then begin Result := False; Exit; end; MX1 := (Pt1.X + Pt2.X) * 0.5; MX2 := (Pt2.X + Pt3.X) * 0.5; MY1 := (Pt1.Y + Pt2.Y) * 0.5; MY2 := (Pt2.Y + Pt3.Y) * 0.5; CenterX := (M1 * MX1 - M2 * Mx2 + My2 - MY1) / (M1 - M2); if (AbsY1Y2 > AbsY2Y3) then CenterY := M1 * (CenterX - MX1) + MY1 else CenterY := M2 * (CenterX - MX2) + MY2; end; DeltaX := Pt2.X - CenterX; DeltaY := Pt2.Y - CenterY; RadSqr := DeltaX * DeltaX + DeltaY * DeltaY; DeltaX := Pt.X - CenterX; DeltaY := Pt.Y - CenterY; DeltaRadSqr := Sqr(DeltaX) + Sqr(DeltaY); Result := (DeltaRadSqr - RadSqr) <= CTolerance; end; begin VertexCount := Length(Points); MaxVerticesCount := VertexCount + CSuperTriangleCount; // Sort points by x value and find maximum and minimum vertex bounds. FastMergeSortX(Points, SortedVertexIndices, Bounds); SetLength(Points, MaxVerticesCount); MaxTriangleCount := 2 * (MaxVerticesCount - 1); SetLength(Result, MaxTriangleCount); MaxEdgeCount := 3 * (MaxVerticesCount - 1); SetLength(Edges, MaxEdgeCount); SetLength(Complete, (MaxTriangleCount + 7) shr 3); // This is to allow calculation of the bounding triangle with Bounds do begin ScaledDeltaMax := 30 * Max(Right - Left, Bottom - Top); Mid := FloatPoint((Left + Right) * 0.5, (Top + Bottom) * 0.5); end; // Set up the super triangle // This is a triangle which encompasses all the sample points. The super // triangle coordinates are added to the end of the vertex list. The super // triangle is the first triangle in the triangle list. Points[VertexCount].Point := FloatPoint(Mid.X - ScaledDeltaMax, Mid.Y - ScaledDeltaMax); Points[VertexCount + 1].Point := FloatPoint(Mid.X + ScaledDeltaMax, Mid.Y); Points[VertexCount + 2].Point := FloatPoint(Mid.X, Mid.Y + ScaledDeltaMax); Result[0, 0] := VertexCount; Result[0, 1] := VertexCount + 1; Result[0, 2] := VertexCount + 2; Complete[0] := 0; TriangleCount := 1; // Include each point one at a time into the existing mesh for I := 0 to VertexCount - 1 do begin EdgeCount := 0; // Set up the edge buffer. // If the point [x, y] lies inside the circumcircle then the hree edges of // that triangle are added to the edge buffer. J := 0; repeat if Complete[J shr 3] and (1 shl (J and $7)) = 0 then begin Inside := InCircle(Points[SortedVertexIndices[I]].Point, Points[Result[J, 0]].Point, Points[Result[J, 1]].Point, Points[Result[J, 2]].Point); ByteIndex := J shr 3; Bit := 1 shl (J and $7); if (CenterX < Points[SortedVertexIndices[I]].Point.X) and ((Sqr(Points[SortedVertexIndices[I]].Point.X - CenterX)) > RadSqr) then Complete[ByteIndex] := Complete[ByteIndex] or Bit else if Inside then begin Edges[EdgeCount + 0, 0] := Result[J, 0]; Edges[EdgeCount + 0, 1] := Result[J, 1]; Edges[EdgeCount + 1, 0] := Result[J, 1]; Edges[EdgeCount + 1, 1] := Result[J, 2]; Edges[EdgeCount + 2, 0] := Result[J, 2]; Edges[EdgeCount + 2, 1] := Result[J, 0]; EdgeCount := EdgeCount + 3; Assert(EdgeCount <= MaxEdgeCount); TriangleCount := TriangleCount - 1; Result[J] := Result[TriangleCount]; Complete[ByteIndex] := (Complete[ByteIndex] and (not Bit)) or (Complete[TriangleCount shr 3] and Bit); Continue; end; end; J := J + 1; until J >= TriangleCount; // Tag multiple edges // Note: if all triangles are specified anticlockwise then all // interior edges are opposite pointing in direction. for J := 0 to EdgeCount - 2 do begin if (Edges[J, 0] <> -1) or (Edges[J, 1] <> -1) then begin for K := J + 1 to EdgeCount - 1 do begin if (Edges[K, 0] <> -1) or (Edges[K, 1] <> -1) then begin if (Edges[J, 0] = Edges[K, 1]) and (Edges[J, 1] = Edges[K, 0]) then begin Edges[J, 0] := -1; Edges[J, 1] := -1; Edges[K, 1] := -1; Edges[K, 0] := -1; end; end; end; end; end; // Form new triangles for the current point. // Skipping over any tagged edges. All edges are arranged in clockwise // order. for J := 0 to EdgeCount - 1 do begin if (Edges[J, 0] <> -1) or (Edges[J, 1] <> -1) then begin Result[TriangleCount, 0] := Edges[J, 0]; Result[TriangleCount, 1] := Edges[J, 1]; Result[TriangleCount, 2] := SortedVertexIndices[I]; ByteIndex := TriangleCount shr 3; Bit := 1 shl (TriangleCount and $7); Complete[ByteIndex] := Complete[ByteIndex] and not Bit; Inc(TriangleCount); Assert(TriangleCount <= MaxTriangleCount); end; end; end; // Remove triangles with supertriangle vertices // These are triangles which have a vertex number greater than VertexCount I := 0; repeat if (Result[I, 0] >= VertexCount) or (Result[I, 1] >= VertexCount) or (Result[I, 2] >= VertexCount) then begin TriangleCount := TriangleCount - 1; Result[I, 0] := Result[TriangleCount, 0]; Result[I, 1] := Result[TriangleCount, 1]; Result[I, 2] := Result[TriangleCount, 2]; I := I - 1; end; I := I + 1; until I >= TriangleCount; SetLength(Points, Length(Points) - 3); SetLength(Result, TriangleCount); end; procedure TGourandShadedDelaunayTrianglesSampler.PrepareSampling; var Index: Integer; begin inherited; // perform triangulation FTriangles := DelaunayTriangulation(FColorPoints); // setup internal barycentric samplers SetLength(FBarycentric, Length(FTriangles)); for Index := 0 to Length(FTriangles) - 1 do begin FBarycentric[Index] := TBarycentricGradientSampler.Create( FColorPoints[FTriangles[Index, 0]], FColorPoints[FTriangles[Index, 1]], FColorPoints[FTriangles[Index, 2]]); FBarycentric[Index].PrepareSampling; end; SetLength(FTriangles, 0); end; function TGourandShadedDelaunayTrianglesSampler.GetSampleFloat(X, Y: TFloat): TColor32; var Index: Integer; U, V, W: TFloat; Dist, MinDist: TFloat; MinIndex: Integer; begin if Length(FBarycentric) = 0 then begin Result := clRed32; Exit; end; // check first barycentric interpolator FBarycentric[0].CalculateBarycentricCoordinates(X, Y, U, V, W); if (U >= 0) and (V >= 0) and (W >= 0) then begin Result := Linear3PointInterpolationProc(FBarycentric[0].Color[0], FBarycentric[0].Color[1], FBarycentric[0].Color[2], U, V, W); Exit; end; // calculate minimum distance MinDist := Sqr(U - 0.5) + Sqr(V - 0.5) + Sqr(W - 0.5); MinIndex := 0; for Index := 1 to High(FBarycentric) do begin // check barycentric interpolator FBarycentric[Index].CalculateBarycentricCoordinates(X, Y, U, V, W); if (U >= 0) and (V >= 0) and (W >= 0) then begin Result := Linear3PointInterpolationProc(FBarycentric[Index].Color[0], FBarycentric[Index].Color[1], FBarycentric[Index].Color[2], U, V, W); Exit; end; // calculate distance and eventually update minimum distance Dist := Sqr(U - 0.5) + Sqr(V - 0.5) + Sqr(W - 0.5); if Dist < MinDist then begin MinDist := Dist; MinIndex := Index; end; end; FBarycentric[MinIndex].CalculateBarycentricCoordinates(X, Y, U, V, W); Result := Linear3PointInterpolationProc(FBarycentric[MinIndex].Color[0], FBarycentric[MinIndex].Color[1], FBarycentric[MinIndex].Color[2], U, V, W); end; procedure TGourandShadedDelaunayTrianglesSampler.FinalizeSampling; var Index: Integer; begin inherited; for Index := 0 to Length(FBarycentric) - 1 do begin FBarycentric[Index].FinalizeSampling; FBarycentric[Index].Free; end; end; { TCustomGradientSampler } constructor TCustomGradientSampler.Create(WrapMode: TWrapMode); begin inherited Create; FGradient := TColor32Gradient.Create(clNone32); FGradient.OnGradientColorsChanged := GradientChangedHandler; FWrapMode := WrapMode; WrapModeChanged; end; constructor TCustomGradientSampler.Create(ColorGradient: TColor32Gradient); begin Create; if Assigned(ColorGradient) then FGradient.Assign(ColorGradient); end; destructor TCustomGradientSampler.Destroy; begin FreeAndNil(FGradient); inherited; end; procedure TCustomGradientSampler.AssignTo(Dest: TPersistent); begin if Dest is TCustomGradientSampler then with TCustomGradientSampler(Dest) do begin FGradient.Assign(Self.FGradient); FInitialized := False; FWrapMode := Self.WrapMode; end else inherited; end; procedure TCustomGradientSampler.SetGradient(const Value: TColor32Gradient); begin if not Assigned(Value) then FGradient.ClearColorStops else Value.AssignTo(Self); GradientSamplerChanged; end; procedure TCustomGradientSampler.SetWrapMode(const Value: TWrapMode); begin if FWrapMode <> Value then begin FWrapMode := Value; WrapModeChanged; end; end; procedure TCustomGradientSampler.WrapModeChanged; begin end; function TCustomGradientSampler.GetSampleFixed(X, Y: TFixed): TColor32; begin Result := GetSampleFloat(X * FixedToFloat, Y * FixedToFloat); end; function TCustomGradientSampler.GetSampleInt(X, Y: Integer): TColor32; begin Result := GetSampleFloat(X, Y); end; procedure TCustomGradientSampler.GradientChangedHandler(Sender: TObject); begin GradientSamplerChanged; end; procedure TCustomGradientSampler.GradientSamplerChanged; begin FInitialized := False; end; procedure TCustomGradientSampler.PrepareSampling; begin inherited; if not FInitialized then begin UpdateInternals; FInitialized := True; end; end; { TCustomGradientLookUpTableSampler } procedure TCustomGradientLookUpTableSampler.AssignTo(Dest: TPersistent); begin inherited; if Dest is TCustomGradientLookUpTableSampler then with TCustomGradientLookUpTableSampler(Dest) do begin FGradientLUT.Assign(Self.FGradientLUT); FWrapProc := Self.FWrapProc; end end; constructor TCustomGradientLookUpTableSampler.Create(WrapMode: TWrapMode = wmMirror); begin FGradientLUT := TColor32LookupTable.Create; inherited Create(WrapMode); end; destructor TCustomGradientLookUpTableSampler.Destroy; begin FGradientLUT.Free; inherited; end; procedure TCustomGradientLookUpTableSampler.UpdateInternals; begin FGradient.FillColorLookUpTable(FGradientLUT); FLutPtr := FGradientLUT.Color32Ptr; FLutMask := FGradientLUT.Mask; FWrapProc := GetWrapProc(WrapMode, FGradientLUT.Mask); end; procedure TCustomGradientLookUpTableSampler.WrapModeChanged; begin inherited; FWrapProc := GetWrapProc(WrapMode); end; { TCustomCenterLutGradientSampler } constructor TCustomCenterLutGradientSampler.Create(WrapMode: TWrapMode = wmMirror); begin inherited Create(WrapMode); FCenter := FloatPoint(0, 0); end; procedure TCustomCenterLutGradientSampler.AssignTo(Dest: TPersistent); begin inherited; if Dest is TCustomCenterLutGradientSampler then TCustomCenterLutGradientSampler(Dest).FCenter := Self.FCenter; end; procedure TCustomCenterLutGradientSampler.Transform(var X, Y: TFloat); begin X := X - FCenter.X; Y := Y - FCenter.Y; inherited; end; { TConicGradientSampler } procedure TConicGradientSampler.AssignTo(Dest: TPersistent); begin inherited; if Dest is TConicGradientSampler then TConicGradientSampler(Dest).FAngle := Self.FAngle; end; function TConicGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32; begin Transform(X, Y); Result := FLutPtr^[FWrapProc(Round(FScale * Abs(FAngle + ArcTan2(Y, X))), FLutMask)]; end; procedure TConicGradientSampler.UpdateInternals; begin inherited; FLutMask := FGradientLUT.Mask; FScale := FLutMask / Pi; end; { TCustomCenterRadiusLutGradientSampler } constructor TCustomCenterRadiusLutGradientSampler.Create(WrapMode: TWrapMode = wmMirror); begin inherited Create(WrapMode); FRadius := 1; RadiusChanged; end; procedure TCustomCenterRadiusLutGradientSampler.AssignTo(Dest: TPersistent); begin inherited; if Dest is TCustomCenterRadiusLutGradientSampler then TCustomCenterRadiusLutGradientSampler(Dest).FRadius := Self.FRadius; end; procedure TCustomCenterRadiusLutGradientSampler.RadiusChanged; begin FInitialized := False; end; procedure TCustomCenterRadiusLutGradientSampler.SetRadius( const Value: TFloat); begin if FRadius <> Value then begin FRadius := Value; RadiusChanged; end; end; { TRadialGradientSampler } function TRadialGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32; begin Transform(X, Y); Result := FGradientLUT.Color32Ptr^[ FWrapProc(Round(Sqrt(Sqr(X) + Sqr(Y)) * FScale), FLutMask)]; end; procedure TRadialGradientSampler.UpdateInternals; begin inherited; FScale := FLutMask / FRadius; end; { TCustomCenterRadiusAngleLutGradientSampler } constructor TCustomCenterRadiusAngleLutGradientSampler.Create(WrapMode: TWrapMode = wmMirror); begin inherited Create(WrapMode); FAngle := 0; FSinCos.X := 1; FSinCos.Y := 0; end; procedure TCustomCenterRadiusAngleLutGradientSampler.AssignTo( Dest: TPersistent); begin inherited; if Dest is TCustomCenterRadiusAngleLutGradientSampler then with TCustomCenterRadiusAngleLutGradientSampler(Dest) do begin FAngle := Self.FAngle; FSinCos := Self.FSinCos; end; end; procedure TCustomCenterRadiusAngleLutGradientSampler.RadiusChanged; begin inherited; FInitialized := False; end; procedure TCustomCenterRadiusAngleLutGradientSampler.AngleChanged; begin GR32_Math.SinCos(FAngle, FSinCos.X, FSinCos.Y); end; procedure TCustomCenterRadiusAngleLutGradientSampler.SetAngle( const Value: TFloat); begin if FAngle <> Value then begin FAngle := Value; AngleChanged; end; end; procedure TCustomCenterRadiusAngleLutGradientSampler.Transform(var X, Y: TFloat); var Temp: TFloat; begin X := X - FCenter.X; Y := Y - FCenter.Y; Temp := X * FSinCos.X + Y * FSinCos.Y; Y := X * FSinCos.Y - Y * FSinCos.X; X := Temp; end; { TDiamondGradientSampler } function TDiamondGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32; begin Transform(X, Y); Result := FLutPtr^[FWrapProc(Round(Max(Abs(X), Abs(Y)) * FScale), FLutMask)]; end; procedure TDiamondGradientSampler.UpdateInternals; begin inherited; FScale := FLutMask / FRadius; end; { TXGradientSampler } function TXGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32; begin Transform(X, Y); Result := FLutPtr^[FWrapProc(Round(X * FScale), FLutMask)]; end; function TXGradientSampler.GetStartPoint: TFloatPoint; begin Result := FCenter; end; function TXGradientSampler.GetEndPoint: TFloatPoint; var X, Y: TFloat; begin GR32_Math.SinCos(Angle - 0.5 * Pi, X, Y); Result := FloatPoint(FCenter.X + X, FCenter.Y + Y); end; procedure TXGradientSampler.SetEndPoint(const Value: TFloatPoint); begin SetPoints(StartPoint, Value); end; procedure TXGradientSampler.SetPoints(const StartPoint, EndPoint: TFloatPoint); begin FCenter := StartPoint; Radius := Distance(EndPoint, StartPoint); Angle := 0.5 * Pi + GetAngleOfPt2FromPt1(EndPoint, StartPoint); end; procedure TXGradientSampler.SetStartPoint(const Value: TFloatPoint); begin SetPoints(Value, EndPoint); end; procedure TXGradientSampler.SimpleGradient( const StartPoint: TFloatPoint; StartColor: TColor32; const EndPoint: TFloatPoint; EndColor: TColor32); begin SetPoints(StartPoint, EndPoint); if Assigned(FGradient) then begin FGradient.ClearColorStops; FGradient.StartColor := StartColor; FGradient.EndColor := EndColor; end; end; procedure TXGradientSampler.UpdateInternals; begin inherited; FScale := FLutMask / FRadius; end; { TXYGradientSampler } function TXYGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32; begin Transform(X, Y); Result := FLutPtr^[FWrapProc(Round((Abs(X) * Abs(Y)) * FScale), FLutMask)]; end; procedure TXYGradientSampler.UpdateInternals; begin inherited; FScale := FLutMask / Sqr(FRadius); end; { TXYSqrtGradientSampler } function TXYSqrtGradientSampler.GetSampleFloat(X, Y: TFloat): TColor32; begin Transform(X, Y); Result := FLutPtr^[FWrapProc(Round(Sqrt(Abs(X) * Abs(Y)) * FScale), FLutMask)]; end; procedure TXYSqrtGradientSampler.UpdateInternals; begin inherited; FScale := FLutMask / FRadius; end; {TCustomGradientPolygonFiller} constructor TCustomGradientPolygonFiller.Create; begin Create(TColor32Gradient.Create(clNone32)); FGradient.OnGradientColorsChanged := GradientColorsChangedHandler; FOwnsGradient := True; FWrapMode := wmClamp; FWrapProc := Clamp; end; constructor TCustomGradientPolygonFiller.Create(ColorGradient: TColor32Gradient); begin FOwnsGradient := False; FGradient := ColorGradient; inherited Create; FWrapMode := wmClamp; FWrapProc := Clamp; end; destructor TCustomGradientPolygonFiller.Destroy; begin if Assigned(FGradient) then if FOwnsGradient then FGradient.Free else FGradient.OnGradientColorsChanged := nil; inherited; end; procedure TCustomGradientPolygonFiller.FillLineNone(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); begin // do nothing! end; procedure TCustomGradientPolygonFiller.FillLineSolid(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); begin FillLineAlpha(Dst, AlphaValues, Length, FGradient.StartColor); end; procedure TCustomGradientPolygonFiller.GradientColorsChangedHandler( Sender: TObject); begin GradientFillerChanged; end; procedure TCustomGradientPolygonFiller.GradientFillerChanged; begin // do nothing end; procedure TCustomGradientPolygonFiller.SetWrapMode(const Value: TWrapMode); begin if FWrapMode <> Value then begin FWrapMode := Value; WrapModeChanged; end; end; procedure TCustomGradientPolygonFiller.WrapModeChanged; begin FWrapProc := GetWrapProc(FWrapMode); end; { TBarycentricGradientPolygonFiller } procedure TBarycentricGradientPolygonFiller.BeginRendering; var NormScale: TFloat; begin inherited; NormScale := 1 / ((FColorPoints[1].Point.Y - FColorPoints[2].Point.Y) * (FColorPoints[0].Point.X - FColorPoints[2].Point.X) + (FColorPoints[2].Point.X - FColorPoints[1].Point.X) * (FColorPoints[0].Point.Y - FColorPoints[2].Point.Y)); FDists[0].X := NormScale * (FColorPoints[2].Point.X - FColorPoints[1].Point.X); FDists[0].Y := NormScale * (FColorPoints[1].Point.Y - FColorPoints[2].Point.Y); FDists[1].X := NormScale * (FColorPoints[0].Point.X - FColorPoints[2].Point.X); FDists[1].Y := NormScale * (FColorPoints[2].Point.Y - FColorPoints[0].Point.Y); end; procedure TBarycentricGradientPolygonFiller.FillLine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; Color32: TColor32; Temp, DotY1, DotY2: TFloat; Barycentric: array [0..1] of TFloat; begin Temp := DstY - FColorPoints[2].Point.Y; DotY1 := FDists[0].X * Temp; DotY2 := FDists[1].X * Temp; for X := DstX to DstX + Length - 1 do begin Temp := (X - FColorPoints[2].Point.X); Barycentric[0] := FDists[0].Y * Temp + DotY1; Barycentric[1] := FDists[1].Y * Temp + DotY2; Color32 := Linear3PointInterpolationProc(FColorPoints[0].Color32, FColorPoints[1].Color32, FColorPoints[2].Color32, Barycentric[0], Barycentric[1], 1 - Barycentric[1] - Barycentric[0]); BlendMemEx(Color32, Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; function TBarycentricGradientPolygonFiller.GetColor(Index: Integer): TColor32; begin if Index in [0 .. 2] then Result := FColorPoints[Index].Color32 else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TBarycentricGradientPolygonFiller.GetColorPoint( Index: Integer): TColor32FloatPoint; begin if Index in [0 .. 2] then Result := FColorPoints[Index] else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TBarycentricGradientPolygonFiller.GetCount: Integer; begin Result := 3; end; function TBarycentricGradientPolygonFiller.GetFillLine: TFillLineEvent; begin Result := FillLine; end; function TBarycentricGradientPolygonFiller.GetPoint( Index: Integer): TFloatPoint; begin if Index in [0 .. 2] then Result := FColorPoints[Index].Point else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; class function TBarycentricGradientPolygonFiller.Linear3PointInterpolation( A, B, C: TColor32; WeightA, WeightB, WeightC: Single): TColor32; begin Result := Linear3PointInterpolationProc(A, B, C, WeightA, WeightB, WeightC); end; procedure TBarycentricGradientPolygonFiller.SetColor(Index: Integer; const Value: TColor32); begin if Index in [0 .. 2] then FColorPoints[Index].Color32 := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TBarycentricGradientPolygonFiller.SetColorPoints( ColorPoints: TArrayOfColor32FloatPoint); begin if Length(ColorPoints) <> 3 then raise Exception.Create(RCStrOnlyExactly3Point); FColorPoints[0] := ColorPoints[0]; FColorPoints[1] := ColorPoints[1]; FColorPoints[2] := ColorPoints[2]; end; procedure TBarycentricGradientPolygonFiller.SetColorPoint(Index: Integer; const Value: TColor32FloatPoint); begin if Index in [0 .. 2] then FColorPoints[Index] := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TBarycentricGradientPolygonFiller.SetColorPoints( Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); begin if (Length(Points) <> 3) or (Length(Colors) <> 3) then raise Exception.Create(RCStrOnlyExactly3Point); FColorPoints[0] := Color32FloatPoint(Colors[0], Points[0]); FColorPoints[1] := Color32FloatPoint(Colors[1], Points[1]); FColorPoints[2] := Color32FloatPoint(Colors[2], Points[2]); end; procedure TBarycentricGradientPolygonFiller.SetPoint(Index: Integer; const Value: TFloatPoint); begin if Index in [0 .. 2] then FColorPoints[Index].Point := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TBarycentricGradientPolygonFiller.SetPoints( Points: TArrayOfFloatPoint); var Index: Integer; begin if Length(Points) <> 3 then raise Exception.Create(RCStrOnlyExactly3Point); for Index := 0 to 2 do FColorPoints[Index].Point := Points[Index]; end; { TCustomArbitrarySparsePointGradientPolygonFiller } procedure TCustomArbitrarySparsePointGradientPolygonFiller.Add( const Point: TFloatPoint; Color: TColor32); var Index: Integer; begin Index := Length(FColorPoints); SetLength(FColorPoints, Index + 1); FColorPoints[Index].Point := Point; FColorPoints[Index].Color32 := Color; end; procedure TCustomArbitrarySparsePointGradientPolygonFiller.Add( const ColorPoint: TColor32FloatPoint); var Index: Integer; begin Index := Length(FColorPoints); SetLength(FColorPoints, Index + 1); FColorPoints[Index].Point := ColorPoint.Point; FColorPoints[Index].Color32 := ColorPoint.Color32; end; procedure TCustomArbitrarySparsePointGradientPolygonFiller.Clear; begin SetLength(FColorPoints, 0); end; function TCustomArbitrarySparsePointGradientPolygonFiller.GetColor( Index: Integer): TColor32; begin if (Index >= 0) and (Index < Length(FColorPoints)) then Result := FColorPoints[Index].Color32 else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TCustomArbitrarySparsePointGradientPolygonFiller.GetColorPoint( Index: Integer): TColor32FloatPoint; begin if (Index >= 0) and (Index < Length(FColorPoints)) then Result := FColorPoints[Index] else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TCustomArbitrarySparsePointGradientPolygonFiller.GetCount: Integer; begin Result := Length(FColorPoints); end; function TCustomArbitrarySparsePointGradientPolygonFiller.GetPoint( Index: Integer): TFloatPoint; begin if (Index >= 0) and (Index < Length(FColorPoints)) then Result := FColorPoints[Index].Point else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetColor(Index: Integer; const Value: TColor32); begin if (Index >= 0) and (Index < Length(FColorPoints)) then FColorPoints[Index].Color32 := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetColorPoint( Index: Integer; const Value: TColor32FloatPoint); begin if (Index >= 0) and (Index < Length(FColorPoints)) then FColorPoints[Index] := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetPoint(Index: Integer; const Value: TFloatPoint); begin if (Index >= 0) and (Index < Length(FColorPoints)) then FColorPoints[Index].Point := Value else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetColorPoints( ColorPoints: TArrayOfColor32FloatPoint); var Index: Integer; begin SetLength(FColorPoints, Length(ColorPoints)); for Index := 0 to High(FColorPoints) do FColorPoints[Index] := ColorPoints[Index]; end; procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetColorPoints( Points: TArrayOfFloatPoint; Colors: TArrayOfColor32); var Index: Integer; begin if Length(Points) <> Length(Colors) then raise Exception.Create(RCStrPointCountMismatch); SetLength(FColorPoints, Length(Points)); for Index := 0 to High(FColorPoints) do begin FColorPoints[Index].Point := Points[Index]; FColorPoints[Index].Color32 := Colors[Index]; end; end; procedure TCustomArbitrarySparsePointGradientPolygonFiller.SetPoints( Points: TArrayOfFloatPoint); var Index: Integer; begin if Length(FColorPoints) <> Length(Points) then raise Exception.Create(RCStrPointCountMismatch); for Index := 0 to High(Points) do FColorPoints[Index].Point := Points[Index]; end; { TGourandShadedDelaunayTrianglesPolygonFiller } procedure TGourandShadedDelaunayTrianglesPolygonFiller.BeginRendering; var Index: Integer; begin inherited; // perform triangulation FTriangles := DelaunayTriangulation(FColorPoints); // setup internal barycentric samplers SetLength(FBarycentric, Length(FTriangles)); for Index := 0 to Length(FTriangles) - 1 do begin FBarycentric[Index] := TBarycentricGradientSampler.Create( FColorPoints[FTriangles[Index, 0]], FColorPoints[FTriangles[Index, 1]], FColorPoints[FTriangles[Index, 2]]); FBarycentric[Index].PrepareSampling; end; SetLength(FTriangles, 0); end; procedure TGourandShadedDelaunayTrianglesPolygonFiller.FillLine3(Dst: PColor32; DstX, DstY, Count: Integer; AlphaValues: PColor32); var X: Integer; begin for X := DstX to DstX + Count - 1 do begin BlendMemEx(FBarycentric[0].GetSampleFloat(X, DstY), Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure TGourandShadedDelaunayTrianglesPolygonFiller.FillLine(Dst: PColor32; DstX, DstY, Count: Integer; AlphaValues: PColor32); var Index: Integer; U, V, W: TFloat; Dist, MinDist: TFloat; MinIndex: Integer; X: Integer; Color32: TColor32; label DrawColor; begin for X := DstX to DstX + Count - 1 do begin // check first barycentric interpolator FBarycentric[0].CalculateBarycentricCoordinates(X, DstY, U, V, W); if (U >= 0) and (V >= 0) and (W >= 0) then begin Color32 := Linear3PointInterpolationProc(FBarycentric[0].Color[0], FBarycentric[0].Color[1], FBarycentric[0].Color[2], U, V, W); goto DrawColor; end; // calculate minimum distance MinDist := Sqr(U - 0.5) + Sqr(V - 0.5) + Sqr(W - 0.5); MinIndex := 0; for Index := 1 to High(FBarycentric) do begin // check barycentric interpolator FBarycentric[Index].CalculateBarycentricCoordinates(X, DstY, U, V, W); if (U >= 0) and (V >= 0) and (W >= 0) then begin Color32 := Linear3PointInterpolationProc(FBarycentric[Index].Color[0], FBarycentric[Index].Color[1], FBarycentric[Index].Color[2], U, V, W); goto DrawColor; end; // calculate distance and eventually update minimum distance Dist := Sqr(U - 0.5) + Sqr(V - 0.5) + Sqr(W - 0.5); if Dist < MinDist then begin MinDist := Dist; MinIndex := Index; end; end; FBarycentric[MinIndex].CalculateBarycentricCoordinates(X, DstY, U, V, W); Color32 := Linear3PointInterpolationProc(FBarycentric[MinIndex].Color[0], FBarycentric[MinIndex].Color[1], FBarycentric[MinIndex].Color[2], U, V, W); DrawColor: BlendMemEx(Color32, Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; function TGourandShadedDelaunayTrianglesPolygonFiller.GetFillLine: TFillLineEvent; begin case Count of 0 .. 2: raise Exception.Create('Too few color points available'); 3: Result := FillLine3; else Result := FillLine; end; end; { TCustomGradientLookupTablePolygonFiller } constructor TCustomGradientLookupTablePolygonFiller.Create; begin inherited Create; FUseLookUpTable := True; // eventually create lookup table if not specified otherwise if not Assigned(FGradientLUT) then begin FGradientLUT := TColor32LookupTable.Create; FGradientLUT.OnOrderChanged := LookUpTableChangedHandler; FOwnsLUT := True; end; end; constructor TCustomGradientLookupTablePolygonFiller.Create( LookupTable: TColor32LookupTable); begin if not Assigned(LookupTable) then raise Exception.Create(RCStrNoLookupTablePassed); FGradientLUT := LookupTable; FUseLookUpTable := True; FOwnsLUT := False; FGradient := nil; FOwnsGradient := False; FWrapMode := wmClamp; FWrapProc := Clamp; end; destructor TCustomGradientLookupTablePolygonFiller.Destroy; begin if FOwnsLUT and Assigned(FGradientLUT) then FGradientLUT.Free; inherited; end; function TCustomGradientLookupTablePolygonFiller.GetLUTNeedsUpdate: Boolean; begin Result := FLUTNeedsUpdate or (FUseLookUpTable and (not FOwnsLUT)); end; procedure TCustomGradientLookupTablePolygonFiller.GradientFillerChanged; begin FLUTNeedsUpdate := True; end; procedure TCustomGradientLookupTablePolygonFiller.SetGradientLUT( const Value: TColor32LookupTable); begin if FGradientLUT <> Value then begin // check whether current look up table is owned and eventually free it if FOwnsLUT then FGradientLUT.Free; // set link to passed look up table FGradientLUT := Value; // if no look up table is specified don't use a look up table if not Assigned(FGradientLUT) then UseLookUpTable := False; end; end; procedure TCustomGradientLookupTablePolygonFiller.SetUseLookUpTable( const Value: Boolean); begin if FUseLookUpTable <> Value then begin FUseLookUpTable := Value; UseLookUpTableChanged; end; end; procedure TCustomGradientLookupTablePolygonFiller.UseLookUpTableChanged; begin if FUseLookUpTable then if not Assigned(FGradientLUT) then begin FGradientLUT := TColor32LookupTable.Create; FGradientLUT.OnOrderChanged := LookUpTableChangedHandler; FOwnsLUT := True; end else else if FOwnsLUT then begin if Assigned(FGradientLUT) then FreeAndNil(FGradientLUT); FOwnsLUT := False; end end; procedure TCustomGradientLookupTablePolygonFiller.LookUpTableChangedHandler(Sender: TObject); begin FLUTNeedsUpdate := True; end; { TCustomLinearGradientPolygonFiller } procedure TCustomLinearGradientPolygonFiller.SetStartPoint( const Value: TFloatPoint); begin if (FStartPoint.X <> Value.X) or (FStartPoint.Y <> Value.Y) then begin FStartPoint := Value; StartPointChanged; end; end; procedure TCustomLinearGradientPolygonFiller.SimpleGradient( const StartPoint: TFloatPoint; StartColor: TColor32; const EndPoint: TFloatPoint; EndColor: TColor32); begin SetPoints(StartPoint, EndPoint); if Assigned(FGradient) then begin FGradient.ClearColorStops; FGradient.StartColor := StartColor; FGradient.EndColor := EndColor; end; end; procedure TCustomLinearGradientPolygonFiller.SimpleGradientX( const StartX: TFloat; StartColor: TColor32; const EndX: TFloat; EndColor: TColor32); begin SimpleGradient( FloatPoint(StartX, 0), StartColor, FloatPoint(EndX, 0), EndColor); end; procedure TCustomLinearGradientPolygonFiller.SimpleGradientY( const StartY: TFloat; StartColor: TColor32; const EndY: TFloat; EndColor: TColor32); begin SimpleGradient( FloatPoint(0, StartY), StartColor, FloatPoint(0, EndY), EndColor); end; procedure TCustomLinearGradientPolygonFiller.SetEndPoint( const Value: TFloatPoint); begin if (FEndPoint.X <> Value.X) or (FEndPoint.Y <> Value.Y) then begin FEndPoint := Value; EndPointChanged; end; end; procedure TCustomLinearGradientPolygonFiller.SetPoints(const StartPoint, EndPoint: TFloatPoint); begin FStartPoint := StartPoint; FEndPoint := EndPoint; GradientFillerChanged; UpdateIncline; end; procedure TCustomLinearGradientPolygonFiller.StartPointChanged; begin GradientFillerChanged; UpdateIncline; end; procedure TCustomLinearGradientPolygonFiller.EndPointChanged; begin GradientFillerChanged; UpdateIncline; end; procedure TCustomLinearGradientPolygonFiller.UpdateIncline; begin if (FEndPoint.X - FStartPoint.X) <> 0 then FIncline := (FEndPoint.Y - FStartPoint.Y) / (FEndPoint.X - FStartPoint.X) else if (FEndPoint.Y - FStartPoint.Y) <> 0 then FIncline := 1 / (FEndPoint.Y - FStartPoint.Y); end; { TLinearGradientPolygonFiller } constructor TLinearGradientPolygonFiller.Create( ColorGradient: TColor32Gradient); begin Create(ColorGradient, True); end; constructor TLinearGradientPolygonFiller.Create( ColorGradient: TColor32Gradient; UseLookupTable: Boolean); begin // create lookup table (and set 'own' & 'use' flags) FGradientLUT := TColor32LookupTable.Create; FGradientLUT.OnOrderChanged := LookUpTableChangedHandler; FOwnsLUT := True; FUseLookUpTable := UseLookupTable; inherited Create(ColorGradient); FGradient.OnGradientColorsChanged := GradientColorsChangedHandler; end; function TLinearGradientPolygonFiller.ColorStopToScanLine(Index, Y: Integer): TFloat; var Offset: array [0 .. 1] of TFloat; begin Offset[0] := FGradient.FGradientColors[Index].Offset; Offset[1] := 1 - Offset[0]; Result := Offset[1] * FStartPoint.X + Offset[0] * FEndPoint.X + FIncline * (Offset[1] * (FStartPoint.Y - Y) + Offset[0] * (FEndPoint.Y - Y)); end; procedure TLinearGradientPolygonFiller.UseLookUpTableChanged; begin inherited; // perfect gradients are only implementd for WrapMode = wmClamp if (not FUseLookUpTable) and (WrapMode in [wmRepeat, wmMirror]) then WrapMode := wmClamp; end; procedure TLinearGradientPolygonFiller.WrapModeChanged; begin inherited; // perfect gradients are only implementd for WrapMode = wmClamp if (not FUseLookUpTable) and (WrapMode in [wmRepeat, wmMirror]) then UseLookUpTable := True; end; function TLinearGradientPolygonFiller.GetFillLine: TFillLineEvent; var GradientCount: Integer; begin if Assigned(FGradient) then GradientCount := FGradient.GradientCount else GradientCount := FGradientLUT.Size; case GradientCount of 0: Result := FillLineNone; 1: Result := FillLineSolid; else if FUseLookUpTable then case FWrapMode of wmClamp: if FStartPoint.X = FEndPoint.X then if FStartPoint.Y = FEndPoint.Y then Result := FillLineVerticalPadExtreme else Result := FillLineVerticalPad else if FStartPoint.X < FEndPoint.X then Result := FillLineHorizontalPadPos else Result := FillLineHorizontalPadNeg; wmMirror, wmRepeat: if FStartPoint.X = FEndPoint.X then Result := FillLineVerticalWrap else if FStartPoint.X < FEndPoint.X then Result := FillLineHorizontalWrapPos else Result := FillLineHorizontalWrapNeg; end else if FStartPoint.X = FEndPoint.X then if FStartPoint.Y = FEndPoint.Y then Result := FillLineVerticalExtreme else Result := FillLineVertical else if FStartPoint.X < FEndPoint.X then Result := FillLinePositive else Result := FillLineNegative; end; end; procedure TLinearGradientPolygonFiller.FillLineVertical(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; Color32: TColor32; begin Color32 := FGradient.GetColorAt((DstY - FStartPoint.Y) * FIncline); for X := DstX to DstX + Length - 1 do begin BlendMemEx(Color32, Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; EMMS; end; procedure TLinearGradientPolygonFiller.FillLineVerticalExtreme(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; Color32: TColor32; begin if DstY < FStartPoint.Y then Color32 := FGradient.StartColor else Color32 := FGradient.EndColor; for X := DstX to DstX + Length - 1 do begin BlendMemEx(Color32, Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; EMMS; end; procedure TLinearGradientPolygonFiller.FillLinePositive(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X, Index: Integer; IntScale, IntValue: Integer; Colors: array [0..1] of TColor32; Scale: TFloat; XOffset: array [0..1] of TFloat; XPos: array [0..2] of Integer; begin // set first offset/position XOffset[0] := ColorStopToScanLine(0, DstY); XPos[0] := Round(XOffset[0]); XPos[2] := DstX + Length; // check if only a solid start color should be drawn. if XPos[0] >= XPos[2] - 1 then begin FillLineSolid(Dst, DstX, DstY, Length, AlphaValues); Exit; end; // set start color Colors[0] := FGradient.FGradientColors[0].Color32; // eventually draw solid start color FillLineAlpha(Dst, AlphaValues, XPos[0] - DstX, Colors[0]); Index := 1; repeat // set start position to be at least DstX if XPos[0] < DstX then XPos[0] := DstX; // set destination color and offset Colors[1] := FGradient.FGradientColors[Index].Color32; XOffset[1] := ColorStopToScanLine(Index, DstY); // calculate destination pixel position XPos[1] := Round(XOffset[1]); if XPos[1] > XPos[2] then XPos[1] := XPos[2]; // check whether if XPos[1] > XPos[0] then begin Scale := 1 / (XOffset[1] - XOffset[0]); IntScale := Round($7FFFFFFF * Scale); IntValue := Round($7FFFFFFF * (XPos[0] - XOffset[0]) * Scale); for X := XPos[0] to XPos[1] - 1 do begin BlendMemEx(CombineReg(Colors[1], Colors[0], IntValue shr 23), Dst^, AlphaValues^); IntValue := IntValue + IntScale; Inc(Dst); Inc(AlphaValues); end; EMMS; end; // check whether further drawing is still necessary if XPos[1] = XPos[2] then Exit; Inc(Index); XPos[0] := XPos[1]; XOffset[0] := XOffset[1]; Colors[0] := Colors[1]; until (Index = FGradient.GradientCount); if XPos[0] < DstX then XPos[0] := DstX; FillLineAlpha(Dst, AlphaValues, XPos[2] - XPos[0], Colors[0]); end; procedure TLinearGradientPolygonFiller.FillLineNegative(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X, Index: Integer; IntScale, IntValue: Integer; Colors: array [0..1] of TColor32; Scale: TFloat; XOffset: array [0..1] of TFloat; XPos: array [0..2] of Integer; begin Index := FGradient.GradientCount - 1; // set first offset/position XOffset[0] := ColorStopToScanLine(Index, DstY); XPos[0] := Round(XOffset[0]); XPos[2] := DstX + Length; // set start color Colors[0] := FGradient.FGradientColors[Index].Color32; // check if only a solid start color should be drawn. if XPos[0] >= XPos[2] - 1 then begin FillLineAlpha(Dst, AlphaValues, Length, Colors[0]); Exit; end; // eventually draw solid start color FillLineAlpha(Dst, AlphaValues, XPos[0] - DstX, Colors[0]); Dec(Index); repeat // set start position to be at least DstX if XPos[0] < DstX then XPos[0] := DstX; // set destination color and offset Colors[1] := FGradient.FGradientColors[Index].Color32; XOffset[1] := ColorStopToScanLine(Index, DstY); // calculate destination pixel position XPos[1] := Round(XOffset[1]); if XPos[1] > XPos[2] then XPos[1] := XPos[2]; // check whether next color needs to be drawn if XPos[1] > XPos[0] then begin Scale := 1 / (XOffset[1] - XOffset[0]); IntScale := Round($7FFFFFFF * Scale); IntValue := Round($7FFFFFFF * (XPos[0] - XOffset[0]) * Scale); for X := XPos[0] to XPos[1] - 1 do begin BlendMemEx(CombineReg(Colors[1], Colors[0], IntValue shr 23), Dst^, AlphaValues^); IntValue := IntValue + IntScale; Inc(Dst); Inc(AlphaValues); end; EMMS; end; // check whether further drawing is still necessary if XPos[1] = XPos[2] then Exit; Dec(Index); XPos[0] := XPos[1]; XOffset[0] := XOffset[1]; Colors[0] := Colors[1]; until (Index < 0); if XPos[0] < DstX then XPos[0] := DstX; FillLineAlpha(Dst, AlphaValues, XPos[2] - XPos[0], Colors[0]); end; procedure TLinearGradientPolygonFiller.FillLineVerticalPad( Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; Color32: TColor32; begin Color32 := FGradientLUT.Color32Ptr^[FWrapProc(Round(FGradientLUT.Mask * (DstY - FStartPoint.Y) * FIncline), FGradientLUT.Mask)]; for X := DstX to DstX + Length - 1 do begin BlendMemEx(Color32, Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; EMMS; end; procedure TLinearGradientPolygonFiller.FillLineVerticalPadExtreme( Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; Color32: TColor32; begin if DstY < FStartPoint.Y then Color32 := FGradientLUT.Color32Ptr^[0] else Color32 := FGradientLUT.Color32Ptr^[FGradientLUT.Mask]; for X := DstX to DstX + Length - 1 do begin BlendMemEx(Color32, Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; EMMS; end; procedure TLinearGradientPolygonFiller.FillLineVerticalWrap( Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; Color32: TColor32; begin X := Round(FGradientLUT.Mask * (DstY - FStartPoint.Y) * FIncline); Color32 := FGradientLUT.Color32Ptr^[FWrapProc(X, Integer(FGradientLUT.Mask))]; for X := DstX to DstX + Length - 1 do begin BlendMemEx(Color32, Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; EMMS; end; procedure TLinearGradientPolygonFiller.FillLineHorizontalPadPos( Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X, XPos, Count, Mask: Integer; ColorLUT: PColor32Array; Scale: TFloat; XOffset: array [0..1] of TFloat; begin XOffset[0] := FStartPoint.X + (FStartPoint.Y - DstY) * FIncline; XOffset[1] := FEndPoint.X + (FEndPoint.Y - DstY) * FIncline; XPos := Round(XOffset[0]); Count := Round(XOffset[1]) - XPos; ColorLUT := FGradientLUT.Color32Ptr; // check if only a solid start color should be drawn. if XPos >= DstX + Length then begin FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[0]); Exit; end; Mask := FGradientLUT.Mask; // check if only a solid end color should be drawn. if XPos + Count < DstX then begin FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[Mask]); Exit; end; Scale := Mask / (XOffset[1] - XOffset[0]); for X := DstX to DstX + Length - 1 do begin BlendMemEx(ColorLUT^[FWrapProc(Round((X - XOffset[0]) * Scale), Mask)], Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure TLinearGradientPolygonFiller.FillLineHorizontalPadNeg( Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X, XPos, Count, Mask: Integer; ColorLUT: PColor32Array; Scale: TFloat; XOffset: array [0..1] of TFloat; begin XOffset[0] := FEndPoint.X + (FEndPoint.Y - DstY) * FIncline; XOffset[1] := FStartPoint.X + (FStartPoint.Y - DstY) * FIncline; XPos := Round(XOffset[0]); Count := Round(XOffset[1]) - XPos; Mask := FGradientLUT.Mask; ColorLUT := FGradientLUT.Color32Ptr; // check if only a solid start color should be drawn. if XPos >= DstX + Length then begin FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[Mask]); Exit; end; // check if only a solid end color should be drawn. if XPos + Count < DstX then begin FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[0]); Exit; end; Scale := Mask / (XOffset[1] - XOffset[0]); for X := DstX to DstX + Length - 1 do begin BlendMemEx(ColorLUT^[FWrapProc(Round((XOffset[1] - X) * Scale), Mask)], Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure TLinearGradientPolygonFiller.FillLineHorizontalWrapPos( Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X, Index, Mask: Integer; ColorLUT: PColor32Array; Scale: TFloat; XOffset: array [0..1] of TFloat; begin XOffset[0] := FStartPoint.X + (FStartPoint.Y - DstY) * FIncline; XOffset[1] := FEndPoint.X + (FEndPoint.Y - DstY) * FIncline; Mask := Integer(FGradientLUT.Mask); ColorLUT := FGradientLUT.Color32Ptr; Scale := Mask / (XOffset[1] - XOffset[0]); for X := DstX to DstX + Length - 1 do begin Index := Round((X - XOffset[0]) * Scale); BlendMemEx(ColorLUT^[FWrapProc(Index, Mask)], Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure TLinearGradientPolygonFiller.FillLineHorizontalWrapNeg( Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X, Index, Mask: Integer; ColorLUT: PColor32Array; Scale: TFloat; XOffset: array [0..1] of TFloat; begin XOffset[0] := FEndPoint.X + (FEndPoint.Y - DstY) * FIncline; XOffset[1] := FStartPoint.X + (FStartPoint.Y - DstY) * FIncline; Mask := Integer(FGradientLUT.Mask); ColorLUT := FGradientLUT.Color32Ptr; Scale := Mask / (XOffset[1] - XOffset[0]); for X := DstX to DstX + Length - 1 do begin Index := Round((XOffset[1] - X) * Scale); BlendMemEx(ColorLUT^[FWrapProc(Index, Mask)], Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure TLinearGradientPolygonFiller.BeginRendering; begin if LookUpTableNeedsUpdate then begin if FUseLookUpTable then begin if not Assigned(FGradientLUT) then raise Exception.Create(RCStrNoTColor32LookupTable); if Assigned(FGradient) then FGradient.FillColorLookUpTable(FGradientLUT); end else if not Assigned(FGradient) then raise Exception.Create(RCStrNoTColor32Gradient); inherited; end; end; { TCustomRadialGradientPolygonFiller } procedure TCustomRadialGradientPolygonFiller.SetEllipseBounds( const Value: TFloatRect); begin if (FEllipseBounds.Left <> Value.Left) or (FEllipseBounds.Top <> Value.Top) or (FEllipseBounds.Right <> Value.Right) or (FEllipseBounds.Bottom <> Value.Bottom) then begin FEllipseBounds := Value; EllipseBoundsChanged; end; end; { TRadialGradientPolygonFiller } constructor TRadialGradientPolygonFiller.Create(Radius: TFloatPoint); begin inherited Create; FRadius := Radius; UpdateEllipseBounds; UpdateRadiusScale; end; constructor TRadialGradientPolygonFiller.Create(Radius, Center: TFloatPoint); begin inherited Create; FRadius := Radius; FCenter := Center; UpdateEllipseBounds; UpdateRadiusScale; end; constructor TRadialGradientPolygonFiller.Create(BoundingBox: TFloatRect); begin Create(FloatPoint(0.5 * (BoundingBox.Right - BoundingBox.Left), 0.5 * (BoundingBox.Bottom - BoundingBox.Top)), FloatPoint(0.5 * (BoundingBox.Right + BoundingBox.Left), 0.5 * (BoundingBox.Bottom + BoundingBox.Top))); end; procedure TRadialGradientPolygonFiller.EllipseBoundsChanged; begin with FEllipseBounds do begin FCenter := FloatPoint((Left + Right) * 0.5, (Top + Bottom) * 0.5); FRadius.X := Round((Right - Left) * 0.5); FRadius.Y := Round((Bottom - Top) * 0.5); end; UpdateRadiusScale; end; procedure TRadialGradientPolygonFiller.SetCenter(const Value: TFloatPoint); begin if (FCenter.X <> Value.X) or (FCenter.Y <> Value.Y) then begin FCenter := Value; UpdateEllipseBounds; end; end; procedure TRadialGradientPolygonFiller.SetRadius(const Value: TFloatPoint); begin if (FRadius.X <> Value.X) or (FRadius.Y <> Value.Y) then begin FRadius := Value; UpdateRadiusScale; UpdateEllipseBounds; end; end; procedure TRadialGradientPolygonFiller.UpdateEllipseBounds; begin with FEllipseBounds do begin Left := FCenter.X - FRadius.X; Top := FCenter.X + FRadius.X; Right := FCenter.Y - FRadius.Y; Bottom := FCenter.Y + FRadius.Y; end; end; procedure TRadialGradientPolygonFiller.UpdateRadiusScale; begin FRadScale := FRadius.X / FRadius.Y; FRadXInv := 1 / FRadius.X; end; procedure TRadialGradientPolygonFiller.BeginRendering; begin if LookUpTableNeedsUpdate then begin if FUseLookUpTable then begin if not Assigned(FGradientLUT) then raise Exception.Create(RCStrNoTColor32LookupTable); if Assigned(FGradient) then FGradient.FillColorLookUpTable(FGradientLUT); end else if not Assigned(FGradient) then raise Exception.Create(RCStrNoTColor32Gradient); inherited; end; end; function TRadialGradientPolygonFiller.GetFillLine: TFillLineEvent; begin case FWrapMode of wmClamp: Result := FillLinePad; wmMirror: Result := FillLineReflect; wmRepeat: Result := FillLineRepeat; end; end; procedure TRadialGradientPolygonFiller.FillLinePad(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X, Index, Count, Mask: Integer; SqrRelRad, RadMax: TFloat; ColorLUT: PColor32Array; YDist, SqrInvRadius: TFloat; Color32: TColor32; begin Mask := Integer(FGradientLUT.Mask); ColorLUT := FGradientLUT.Color32Ptr; // small optimization Index := Ceil(FCenter.X - FRadius.X); if Index > DstX then begin Count := Min((Index - DstX), Length); FillLineAlpha(Dst, AlphaValues, Count, ColorLUT^[Mask]); Length := Length - Count; if Length = 0 then Exit; DstX := Index; end; // further optimization if Abs(DstY - FCenter.Y) > FRadius.Y then begin FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[Mask]); Exit; end; SqrInvRadius := Sqr(FRadXInv); YDist := Sqr((DstY - FCenter.Y) * FRadScale); RadMax := (Sqr(FRadius.X) + YDist) * SqrInvRadius; for X := DstX to DstX + Length - 1 do begin SqrRelRad := (Sqr(X - FCenter.X) + YDist) * SqrInvRadius; if SqrRelRad > RadMax then Index := Mask else Index := Min(Round(Mask * FastSqrt(SqrRelRad)), Mask); Color32 := ColorLUT^[Index]; BlendMemEx(Color32, Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure TRadialGradientPolygonFiller.FillLineReflect(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X, Index, Mask, DivResult: Integer; SqrInvRadius: TFloat; YDist: TFloat; ColorLUT: PColor32Array; Color32: TColor32; begin SqrInvRadius := Sqr(FRadXInv); YDist := Sqr((DstY - FCenter.Y) * FRadScale); Mask := Integer(FGradientLUT.Mask); ColorLUT := FGradientLUT.Color32Ptr; for X := DstX to DstX + Length - 1 do begin Index := Round(Mask * FastSqrt((Sqr(X - FCenter.X) + YDist) * SqrInvRadius)); DivResult := DivMod(Index, FGradientLUT.Size, Index); if Odd(DivResult) then Index := Mask - Index; Color32 := ColorLUT^[Index]; BlendMemEx(Color32, Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure TRadialGradientPolygonFiller.FillLineRepeat(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X, Mask: Integer; YDist, SqrInvRadius: TFloat; ColorLUT: PColor32Array; Color32: TColor32; begin SqrInvRadius := Sqr(FRadXInv); YDist := Sqr((DstY - FCenter.Y) * FRadScale); Mask := Integer(FGradientLUT.Mask); ColorLUT := FGradientLUT.Color32Ptr; for X := DstX to DstX + Length - 1 do begin Color32 := ColorLUT^[Round(Mask * FastSqrt((Sqr(X - FCenter.X) + YDist) * SqrInvRadius)) mod FGradientLUT.Size]; BlendMemEx(Color32, Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; { TSVGRadialGradientPolygonFiller } constructor TSVGRadialGradientPolygonFiller.Create(EllipseBounds: TFloatRect); begin inherited Create; SetParameters(EllipseBounds); end; constructor TSVGRadialGradientPolygonFiller.Create(EllipseBounds: TFloatRect; FocalPoint: TFloatPoint); begin inherited Create; SetParameters(EllipseBounds, FocalPoint); end; procedure TSVGRadialGradientPolygonFiller.EllipseBoundsChanged; begin GradientFillerChanged; end; procedure TSVGRadialGradientPolygonFiller.SetFocalPoint(const Value: TFloatPoint); begin if (FFocalPointNative.X <> Value.X) and (FFocalPointNative.Y <> Value.Y) then begin FFocalPointNative := Value; GradientFillerChanged; end; end; procedure TSVGRadialGradientPolygonFiller.SetParameters( EllipseBounds: TFloatRect); begin FEllipseBounds := EllipseBounds; FFocalPointNative := FloatPoint( 0.5 * (FEllipseBounds.Left + FEllipseBounds.Right), 0.5 * (FEllipseBounds.Top + FEllipseBounds.Bottom)); GradientFillerChanged; end; procedure TSVGRadialGradientPolygonFiller.SetParameters( EllipseBounds: TFloatRect; FocalPoint: TFloatPoint); begin FEllipseBounds := EllipseBounds; FFocalPointNative := FocalPoint; GradientFillerChanged; end; procedure TSVGRadialGradientPolygonFiller.InitMembers; var X, Y: TFloat; Temp: TFloat; begin FRadius.X := (FEllipseBounds.Right - FEllipseBounds.Left) * 0.5; FRadius.Y := (FEllipseBounds.Bottom - FEllipseBounds.Top) * 0.5; FCenter.X := (FEllipseBounds.Right + FEllipseBounds.Left) * 0.5; FCenter.Y := (FEllipseBounds.Bottom + FEllipseBounds.Top) * 0.5; FOffset.X := FEllipseBounds.Left; FOffset.Y := FEllipseBounds.Top; // make FFocalPoint relative to the ellipse midpoint ... FFocalPt.X := FFocalPointNative.X - FCenter.X; FFocalPt.Y := FFocalPointNative.Y - FCenter.Y; // make sure the focal point stays within the bounding ellipse ... if Abs(FFocalPt.X) < CFloatTolerance then begin X := 0; if FFocalPt.Y < 0 then Y := -1 else Y := 1; end else begin Temp := FRadius.X * FFocalPt.Y / (FRadius.Y * FFocalPt.X); X := 1 / FastSqrtBab1(1 + Sqr(Temp)); Y := Temp * X; end; if FFocalPt.X < 0 then begin X := -X; Y := -Y; end; X := X * FRadius.X; Y := Y * FRadius.Y; if (Y * Y + X * X) < (Sqr(FFocalPt.X) + Sqr(FFocalPt.Y)) then begin FFocalPt.X := 0.999 * X; FFocalPt.Y := 0.999 * Y; end; // Because the slope of vertical lines is infinite, we need to find where a // vertical line through the FocalPoint intersects with the Ellipse, and // store the distances from the focal point to these 2 intersections points FVertDist := FRadius.Y * FastSqrtBab1(1 - Sqr(FFocalPt.X) / Sqr(FRadius.X)); end; procedure TSVGRadialGradientPolygonFiller.BeginRendering; begin if LookUpTableNeedsUpdate then begin if FUseLookUpTable then begin if not Assigned(FGradientLUT) then raise Exception.Create(RCStrNoTColor32LookupTable); if Assigned(FGradient) then FGradient.FillColorLookUpTable(FGradientLUT); end else if not Assigned(FGradient) then raise Exception.Create(RCStrNoTColor32Gradient); inherited; end; InitMembers; end; function TSVGRadialGradientPolygonFiller.GetFillLine: TFillLineEvent; begin Result := FillLineEllipse; end; procedure TSVGRadialGradientPolygonFiller.FillLineEllipse(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X, Mask: Integer; ColorLUT: PColor32Array; Rad, Rad2, X2, Y2: TFloat; m, b, Qa, Qb, Qc, Qz, XSqr: Double; RelPos: TFloatPoint; Color32: TColor32; begin if (FRadius.X = 0) or (FRadius.Y = 0) then Exit; ColorLUT := FGradientLUT.Color32Ptr; RelPos.Y := DstY - FCenter.Y - FFocalPt.Y; Mask := Integer(FGradientLUT.Mask); // check if out of bounds (vertically) if (DstY < FOffset.Y) or (DstY >= (FRadius.Y * 2) + 1 + FOffset.Y) then begin FillLineAlpha(Dst, AlphaValues, Length, ColorLUT^[Mask]); Exit; end; for X := DstX to DstX + Length - 1 do begin // check if out of bounds (horizontally) if (X < FOffset.X) or (X >= (FRadius.X * 2) + 1 + FOffset.X) then Color32 := ColorLUT^[Mask] else begin RelPos.X := X - FCenter.X - FFocalPt.X; if Abs(RelPos.X) < CFloatTolerance then //ie on the vertical line (see above) begin Assert(Abs(X - FCenter.X) <= FRadius.X); Rad := Abs(RelPos.Y); if Abs(Abs(X - FCenter.X)) <= FRadius.X then begin if RelPos.Y < 0 then Rad2 := Abs(-FVertDist - FFocalPt.Y) else Rad2 := Abs( FVertDist - FFocalPt.Y); if Rad >= Rad2 then Color32 := ColorLUT^[Mask] else Color32 := ColorLUT^[Round(Mask * Rad / Rad2)]; end else Color32 := ColorLUT^[Mask]; end else begin m := RelPos.Y / RelPos.X; b := FFocalPt.Y - m * FFocalPt.X; XSqr := Sqr(FRadius.X); // apply quadratic equation ... Qa := 2 * (Sqr(FRadius.Y) + XSqr * m * m); Qb := XSqr * 2 * m * b; Qc := XSqr * (b * b - Sqr(FRadius.Y)); Qz := Qb * Qb - 2 * Qa * Qc; if Qz >= 0 then begin Qz := FastSqrtBab2(Qz); Qa := 1 / Qa; X2 := (-Qb + Qz) * Qa; if (FFocalPt.X > X2) = (RelPos.X > 0) then X2 := -(Qb + Qz) * Qa; Y2 := m * X2 + b; Rad := Sqr(RelPos.X) + Sqr(RelPos.Y); Rad2 := Sqr(X2 - FFocalPt.X) + Sqr(Y2 - FFocalPt.Y); if Rad >= Rad2 then Color32 := ColorLUT^[Mask] else Color32 := ColorLUT^[Round(Mask * FastSqrtBab1(Rad / Rad2))]; end else Color32 := ColorLUT^[Mask] end; end; BlendMemEx(Color32, Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; const FID_LINEAR3 = 0; FID_LINEAR4 = 1; procedure RegisterBindings; begin BlendRegistry := NewRegistry('GR32_ColorGradients bindings'); BlendRegistry.RegisterBinding(FID_LINEAR3, @@Linear3PointInterpolationProc); BlendRegistry.RegisterBinding(FID_LINEAR4, @@Linear4PointInterpolationProc); // pure pascal BlendRegistry.Add(FID_LINEAR3, @Linear3PointInterpolation_Pas); BlendRegistry.Add(FID_LINEAR4, @Linear4PointInterpolation_Pas); {$IFNDEF PUREPASCAL} {$IFNDEF OMIT_SSE2} BlendRegistry.Add(FID_LINEAR3, @Linear3PointInterpolation_SSE2, [ciSSE2]); BlendRegistry.Add(FID_LINEAR4, @Linear4PointInterpolation_SSE2, [ciSSE2]); {$ENDIF} {$ENDIF} BlendRegistry.RebindAll; end; initialization RegisterBindings; end. |
Added src/graphics32/GR32_ColorPicker.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 | unit GR32_ColorPicker; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Christan-W. Budde <Christian@savioursofsoul.de> * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LCLType, LMessages, Types, {$IFDEF MSWINDOWS} Windows, {$ENDIF} {$ELSE} Windows, Messages, Types, {$ENDIF} Classes, Controls, Forms, GR32, GR32_Polygons, GR32_Containers, GR32_ColorGradients; type TScreenColorPickerForm = class(TCustomForm) private FSelectedColor: TColor32; FOnColorSelected: TNotifyEvent; protected procedure CreateParams(var Params: TCreateParams); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; public constructor Create(AOwner: TComponent); override; property SelectedColor: TColor32 read FSelectedColor write FSelectedColor; property OnColorSelected: TNotifyEvent read FOnColorSelected write FOnColorSelected; published property OnKeyUp; property OnKeyPress; property OnKeyDown; property OnMouseMove; property OnMouseUp; property OnMouseDown; end; THueCirclePolygonFiller = class(TCustomPolygonFiller) private FCenter: TFloatPoint; FWebSafe: Boolean; protected function GetFillLine: TFillLineEvent; override; procedure FillLine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); virtual; procedure FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); virtual; public constructor Create(Center: TFloatPoint; WebSafe: Boolean = False); property Center: TFloatPoint read FCenter write FCenter; property WebSafe: Boolean read FWebSafe write FWebSafe; end; THueSaturationCirclePolygonFiller = class(THueCirclePolygonFiller) private FRadius: Single; FInvRadius: Single; FValue: Single; procedure SetRadius(const Value: Single); protected procedure FillLine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); override; procedure FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); override; public constructor Create(Center: TFloatPoint; Radius, Value: Single; WebSafe: Boolean = False); property Radius: Single read FRadius write SetRadius; property Value: Single read FValue write FValue; end; TBarycentricGradientPolygonFillerEx = class(TBarycentricGradientPolygonFiller) private FWebSafe: Boolean; protected function GetFillLine: TFillLineEvent; override; procedure FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); public property WebSafe: Boolean read FWebSafe write FWebSafe; end; TVisualAid = set of (vaHueLine, vaSaturationCircle, vaSelection); TVisualAidRenderType = (vatSolid, vatInvert, vatBW); TAdjustCalc = procedure (X, Y: Single) of object; TPreserveComponent = set of (pcHue, pcSaturation, pcLuminance, pcValue); TVisualAidOptions = class(TPersistent) private FOwner: TPersistent; FRenderType: TVisualAidRenderType; FColor: TColor32; FLineWidth: Single; procedure SetRenderType(const Value: TVisualAidRenderType); procedure SetColor(const Value: TColor32); procedure SetLineWidth(const Value: Single); protected function GetOwner: TPersistent; override; procedure Changed; virtual; public constructor Create(AOwner: TPersistent); virtual; property Owner: TPersistent read FOwner; published property RenderType: TVisualAidRenderType read FRenderType write SetRenderType default vatInvert; property Color: TColor32 read FColor write SetColor; property LineWidth: Single read FLineWidth write SetLineWidth; end; TCustomColorPicker = class(TCustomControl) private FBuffer: TBitmap32; FAdjustCalc: TAdjustCalc; FSelectedColor: TColor32; FBufferValid: Boolean; FPreserveComponent: TPreserveComponent; FVisualAidOptions: TVisualAidOptions; FWebSafe: Boolean; FBorder: Boolean; FOnChanged: TNotifyEvent; procedure SetBorder(const Value: Boolean); procedure SetWebSafe(const Value: Boolean); procedure SetSelectedColor(const Value: TColor32); {$IFDEF FPC} procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; procedure WMGetDlgCode(var Msg: TLMessage); message LM_GETDLGCODE; {$ELSE} procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND; procedure WMGetDlgCode(var Msg: TWmGetDlgCode); message WM_GETDLGCODE; {$ENDIF} protected procedure Paint; override; procedure PaintColorPicker; virtual; abstract; procedure SelectedColorChanged; virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Invalidate; override; procedure Resize; override; property Border: Boolean read FBorder write SetBorder default False; property VisualAidOptions: TVisualAidOptions read FVisualAidOptions; property SelectedColor: TColor32 read FSelectedColor write SetSelectedColor; property WebSafe: Boolean read FWebSafe write SetWebSafe; property OnChanged: TNotifyEvent read FOnChanged write FOnChanged; end; TColorComponent = (ccRed, ccGreen, ccBlue, ccAlpha); TCustomColorPickerComponent = class(TCustomColorPicker) private FMouseDown: Boolean; FColorComponent: TColorComponent; procedure SetColorComponent(const Value: TColorComponent); protected procedure PaintColorPicker; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; public constructor Create(AOwner: TComponent); override; property ColorComponent: TColorComponent read FColorComponent write SetColorComponent; end; TCustomColorPickerRGBA = class(TCustomColorPicker) private FBarHeight: Integer; FSpaceHeight: Integer; procedure SetBarHeight(const Value: Integer); procedure SetSpaceHeight(const Value: Integer); procedure PickAlpha(X, Y: Single); procedure PickBlue(X, Y: Single); procedure PickGreen(X, Y: Single); procedure PickRed(X, Y: Single); protected procedure PaintColorPicker; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; public constructor Create(AOwner: TComponent); override; property BarHeight: Integer read FBarHeight write SetBarHeight default 24; property SpaceHeight: Integer read FSpaceHeight write SetSpaceHeight default 8; end; TMarkerType = (mtCross, mtCircle); TCustomColorPickerHS = class(TCustomColorPicker) private FHue: Single; FSaturation: Single; FMarkerType: TMarkerType; procedure PickHue(X, Y: Single); procedure SetHue(const Value: Single); procedure SetSaturation(const Value: Single); procedure SetMarkerType(const Value: TMarkerType); protected procedure PaintColorPicker; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; procedure SelectedColorChanged; override; public constructor Create(AOwner: TComponent); override; property MarkerType: TMarkerType read FMarkerType write SetMarkerType; property Hue: Single read FHue write SetHue; property Saturation: Single read FSaturation write SetSaturation; end; TCustomColorPickerHSV = class(TCustomColorPicker) private FCenter: TFloatPoint; FHue: Single; FRadius: TFloat; FCircleSteps: Integer; FSaturation: Single; FValue: Single; FVisualAid: TVisualAid; procedure PickHue(X, Y: Single); procedure PickValue(X, Y: Single); procedure SetHue(const Value: Single); procedure SetSaturation(const Value: Single); procedure SetValue(const Value: Single); procedure SetVisualAid(const Value: TVisualAid); protected procedure PaintColorPicker; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; procedure SelectedColorChanged; override; public constructor Create(AOwner: TComponent); override; procedure Resize; override; property Hue: Single read FHue write SetHue; property Saturation: Single read FSaturation write SetSaturation; property Value: Single read FValue write SetValue; property VisualAid: TVisualAid read FVisualAid write SetVisualAid; end; TVisualAidGTK = set of (vagHueLine, vagSelection); TCustomColorPickerGTK = class(TCustomColorPicker) private FCenter: TFloatPoint; FHue: Single; FRadius: TFloat; FInnerRadius: TFloat; FCircleSteps: Integer; FSaturation: Single; FValue: Single; FVisualAid: TVisualAidGTK; procedure PickHue(X, Y: Single); procedure PickSaturationValue(X, Y: Single); procedure SetHue(const Value: Single); procedure SetSaturation(const Value: Single); procedure SetValue(const Value: Single); procedure SetVisualAid(const Value: TVisualAidGTK); procedure SetRadius(const Value: TFloat); protected procedure PaintColorPicker; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; procedure SelectedColorChanged; override; property Radius: TFloat read FRadius write SetRadius; property Center: TFloatPoint read FCenter write FCenter; public constructor Create(AOwner: TComponent); override; procedure Resize; override; property Hue: Single read FHue write SetHue; property Saturation: Single read FSaturation write SetSaturation; property Value: Single read FValue write SetValue; property VisualAid: TVisualAidGTK read FVisualAid write SetVisualAid; end; TColorPickerComponent = class(TCustomColorPickerComponent) published property Align; property Anchors; property Border; property ColorComponent; property DragCursor; property DragKind; property Enabled; {$IFNDEF FPC} property ParentBackground; {$ENDIF} property ParentColor; property ParentShowHint; property PopupMenu; property SelectedColor; property TabOrder; property TabStop; property VisualAidOptions; property WebSafe default False; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnChanged; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; {$IFDEF COMPILER2005_UP} property OnMouseEnter; property OnMouseLeave; {$ENDIF} property OnResize; property OnStartDrag; end; TColorPickerRGBA = class(TCustomColorPickerRGBA) published property Align; property Anchors; property BarHeight; property Border; property DragCursor; property DragKind; property Enabled; {$IFNDEF FPC} property ParentBackground; {$ENDIF} property ParentColor; property ParentShowHint; property PopupMenu; property SelectedColor; property SpaceHeight; property TabOrder; property TabStop; property VisualAidOptions; property WebSafe default False; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnChanged; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; {$IFDEF COMPILER2005_UP} property OnMouseEnter; property OnMouseLeave; {$ENDIF} property OnResize; property OnStartDrag; end; TColorPickerHS = class(TCustomColorPickerHS) published property Align; property Anchors; property DragCursor; property DragKind; property Enabled; property Hue; property MarkerType; {$IFNDEF FPC} property ParentBackground; {$ENDIF} property ParentColor; property ParentShowHint; property PopupMenu; property Saturation; property SelectedColor; property TabOrder; property TabStop; property WebSafe default False; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnChanged; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; {$IFDEF COMPILER2005_UP} property OnMouseEnter; property OnMouseLeave; {$ENDIF} property OnResize; property OnStartDrag; end; TColorPickerHSV = class(TCustomColorPickerHSV) published property Align; property Anchors; property Border; property DragCursor; property DragKind; property Enabled; property Hue; {$IFNDEF FPC} property ParentBackground; {$ENDIF} property ParentColor; property ParentShowHint; property PopupMenu; property Saturation; property SelectedColor; property TabOrder; property TabStop; property Value; property VisualAid default [vaHueLine, vaSaturationCircle, vaSelection]; property VisualAidOptions; property WebSafe default False; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnChanged; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; {$IFDEF COMPILER2005_UP} property OnMouseEnter; property OnMouseLeave; {$ENDIF} property OnResize; property OnStartDrag; end; TColorPickerGTK = class(TCustomColorPickerGTK) published property Align; property Anchors; property Border; property DragCursor; property DragKind; property Enabled; property Hue; {$IFNDEF FPC} property ParentBackground; {$ENDIF} property ParentColor; property ParentShowHint; property PopupMenu; property Saturation; property SelectedColor; property TabOrder; property TabStop; property Value; property VisualAid default [vagHueLine, vagSelection]; property VisualAidOptions; property WebSafe default False; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnChanged; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; {$IFDEF COMPILER2005_UP} property OnMouseEnter; property OnMouseLeave; {$ENDIF} property OnResize; property OnStartDrag; end; implementation uses Math, Graphics, GR32_Backends, GR32_Math, GR32_Blend, GR32_VectorUtils; procedure RoundToWebSafe(var Color: TColor32); begin with TColor32Entry(Color) do begin R := ((R + $19) div $33) * $33; G := ((G + $19) div $33) * $33; B := ((B + $19) div $33) * $33; end; end; {$IFDEF MSWINDOWS} function GetDesktopColor(const x, y: Integer): TColor32; var c: TCanvas; begin c := TCanvas.Create; try c.Handle := GetWindowDC(GetDesktopWindow); Result := Color32(GetPixel(c.Handle, x, y)); finally c.Free; end; end; {$ENDIF} { TVisualAidOptions } constructor TVisualAidOptions.Create(AOwner: TPersistent); begin inherited Create; FOwner := AOwner; FColor := $AF000000; FRenderType := vatInvert; FLineWidth := 2; end; procedure TVisualAidOptions.Changed; begin if Owner is TCustomColorPicker then TCustomColorPicker(Owner).Invalidate; end; function TVisualAidOptions.GetOwner: TPersistent; begin if FOwner is TPersistent then Result := TPersistent(FOwner) else Result := nil; end; procedure TVisualAidOptions.SetColor(const Value: TColor32); begin if FColor <> Value then begin FColor := Value; if FRenderType = vatSolid then Changed; end; end; procedure TVisualAidOptions.SetLineWidth(const Value: Single); begin if FLineWidth <> Value then begin FLineWidth := Value; Changed; end; end; procedure TVisualAidOptions.SetRenderType(const Value: TVisualAidRenderType); begin if FRenderType <> Value then begin FRenderType := Value; Changed; end; end; { TScreenColorPickerForm } constructor TScreenColorPickerForm.Create(AOwner: TComponent); begin inherited CreateNew(AOwner); Align := alClient; BorderIcons := []; BorderStyle := bsNone; Caption := 'Pick a color...'; FormStyle := fsStayOnTop; Position := poDefault; FSelectedColor := 0; end; procedure TScreenColorPickerForm.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.ExStyle := WS_EX_TRANSPARENT or WS_EX_TOPMOST; end; procedure TScreenColorPickerForm.KeyDown(var Key: Word; Shift: TShiftState); begin if (Key = VK_ESCAPE) then ModalResult := mrCancel else inherited; end; procedure TScreenColorPickerForm.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then begin {$IFDEF MSWINDOWS} FSelectedColor := GetDesktopColor(X, Y); if Assigned(FOnColorSelected) then FOnColorSelected(Self); {$ENDIF} ModalResult := mrOk end else inherited; end; procedure TScreenColorPickerForm.MouseMove(Shift: TShiftState; X, Y: Integer); begin FSelectedColor := GetDesktopColor(X, Y); inherited; end; { THueCirclePolygonFiller } constructor THueCirclePolygonFiller.Create(Center: TFloatPoint; WebSafe: Boolean = False); begin FCenter := Center; FWebSafe := WebSafe; inherited Create; end; procedure THueCirclePolygonFiller.FillLine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; H: Single; const CTwoPiInv = 1 / (2 * Pi); begin for X := DstX to DstX + Length - 1 do begin // calculate squared distance H := 0.5 + ArcTan2(DstY - FCenter.Y, X - FCenter.X) * CTwoPiInv; CombineMem(HSVtoRGB(H, 1, 1), Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure THueCirclePolygonFiller.FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; H: Single; Color: TColor32; const CTwoPiInv = 1 / (2 * Pi); begin for X := DstX to DstX + Length - 1 do begin // calculate squared distance H := 0.5 + ArcTan2(DstY - FCenter.Y, X - FCenter.X) * CTwoPiInv; Color := HSVtoRGB(H, 1, 1); RoundToWebSafe(Color); CombineMem(Color, Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; function THueCirclePolygonFiller.GetFillLine: TFillLineEvent; begin if FWebSafe then Result := FillLineWebSafe else Result := FillLine; end; { THueSaturationCirclePolygonFiller } constructor THueSaturationCirclePolygonFiller.Create(Center: TFloatPoint; Radius, Value: Single; WebSafe: Boolean = False); begin FRadius := Max(1, Radius); FInvRadius := 1 / FRadius; FValue := Value; inherited Create(Center, WebSafe); end; procedure THueSaturationCirclePolygonFiller.FillLine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; SqrYDist, H, S: Single; const CTwoPiInv = 1 / (2 * Pi); begin SqrYDist := Sqr(DstY - FCenter.Y); for X := DstX to DstX + Length - 1 do begin // calculate squared distance H := 0.5 + ArcTan2(DstY - FCenter.Y, X - FCenter.X) * CTwoPiInv; S := Sqrt(Sqr(X - Center.X) + SqrYDist) * FInvRadius; if S > 1 then S := 1; CombineMem(HSVtoRGB(H, S, Value), Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure THueSaturationCirclePolygonFiller.FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; SqrYDist, H, S: Single; Color: TColor32; const CTwoPiInv = 1 / (2 * Pi); begin SqrYDist := Sqr(DstY - FCenter.Y); for X := DstX to DstX + Length - 1 do begin // calculate squared distance H := 0.5 + ArcTan2(DstY - FCenter.Y, X - FCenter.X) * CTwoPiInv; S := Sqrt(Sqr(X - Center.X) + SqrYDist) * FInvRadius; if S > 1 then S := 1; Color := HSVtoRGB(H, S, Value); RoundToWebSafe(Color); CombineMem(Color, Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure THueSaturationCirclePolygonFiller.SetRadius(const Value: Single); begin if FRadius <> Value then begin FRadius := Value; FInvRadius := 1 / FRadius; end; end; { TBarycentricGradientPolygonFillerEx } procedure TBarycentricGradientPolygonFillerEx.FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; Color32: TColor32; Temp, DotY1, DotY2: TFloat; Barycentric: array [0..1] of TFloat; begin Temp := DstY - FColorPoints[2].Point.Y; DotY1 := FDists[0].X * Temp; DotY2 := FDists[1].X * Temp; for X := DstX to DstX + Length - 1 do begin Temp := (X - FColorPoints[2].Point.X); Barycentric[0] := FDists[0].Y * Temp + DotY1; Barycentric[1] := FDists[1].Y * Temp + DotY2; Color32 := Linear3PointInterpolation(FColorPoints[0].Color32, FColorPoints[1].Color32, FColorPoints[2].Color32, Barycentric[0], Barycentric[1], 1 - Barycentric[1] - Barycentric[0]); RoundToWebSafe(Color32); BlendMemEx(Color32, Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; function TBarycentricGradientPolygonFillerEx.GetFillLine: TFillLineEvent; begin if FWebSafe then Result := FillLineWebSafe else Result := inherited GetFillLine; end; { TCustomColorPicker } constructor TCustomColorPicker.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csOpaque]; FBuffer := TBitmap32.Create; FPreserveComponent := []; FSelectedColor := clSalmon32; FVisualAidOptions := TVisualAidOptions.Create(Self); end; destructor TCustomColorPicker.Destroy; begin FVisualAidOptions.Free; FBuffer.Free; inherited; end; procedure TCustomColorPicker.Invalidate; begin FBufferValid := False; inherited; end; procedure TCustomColorPicker.Paint; begin if not Assigned(Parent) then Exit; if not FBufferValid then begin (FBuffer.Backend as IPaintSupport).ImageNeeded; PaintColorPicker; (FBuffer.Backend as IPaintSupport).CheckPixmap; FBufferValid := True; end; FBuffer.Lock; with Canvas do try (FBuffer.Backend as IDeviceContextSupport).DrawTo(Canvas.Handle, 0, 0); finally FBuffer.Unlock; end; end; procedure TCustomColorPicker.Resize; begin inherited; FBuffer.SetSize(Width, Height); FBufferValid := False; end; procedure TCustomColorPicker.SelectedColorChanged; begin if Assigned(FOnChanged) then FOnChanged(Self); Invalidate; end; procedure TCustomColorPicker.SetBorder(const Value: Boolean); begin if FBorder <> Value then begin FBorder := Value; Invalidate; end; end; procedure TCustomColorPicker.SetSelectedColor(const Value: TColor32); begin if FSelectedColor <> Value then begin FSelectedColor := Value; SelectedColorChanged; end; end; procedure TCustomColorPicker.SetWebSafe(const Value: Boolean); begin if FWebSafe <> Value then begin FWebSafe := Value; Invalidate; end; end; procedure TCustomColorPicker.WMEraseBkgnd(var Message: {$IFDEF FPC}TLmEraseBkgnd{$ELSE}TWmEraseBkgnd{$ENDIF}); begin Message.Result := 1; end; procedure TCustomColorPicker.WMGetDlgCode(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TWmGetDlgCode{$ENDIF}); begin with Msg do Result := Result or DLGC_WANTARROWS; end; { TCustomColorPickerComponent } constructor TCustomColorPickerComponent.Create(AOwner: TComponent); begin inherited; FVisualAidOptions.Color := clBlack32; FVisualAidOptions.LineWidth := 1.5; end; procedure TCustomColorPickerComponent.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FMouseDown := (Button = mbLeft); inherited; end; procedure TCustomColorPickerComponent.MouseMove(Shift: TShiftState; X, Y: Integer); var Value: Single; Color: TColor32Entry; begin if FMouseDown then begin Value := EnsureRange((X - 3) / (Width - 3), 0, 1); Color := TColor32Entry(SelectedColor); case FColorComponent of ccRed: Color.R := Round(Value * 255); ccGreen: Color.G := Round(Value * 255); ccBlue: Color.B := Round(Value * 255); ccAlpha: Color.A := Round(Value * 255); end; SelectedColor := Color.ARGB; end; inherited; end; procedure TCustomColorPickerComponent.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Button = mbLeft) then FMouseDown := False; inherited; end; procedure TCustomColorPickerComponent.PaintColorPicker; var Polygon: TArrayOfFloatPoint; InvertFiller: TInvertPolygonFiller; procedure RenderPolygon; begin case FVisualAidOptions.RenderType of vatInvert: PolygonFS(FBuffer, Polygon, InvertFiller); vatBW: if Intensity(FSelectedColor) < 127 then PolygonFS(FBuffer, Polygon, clWhite32) else PolygonFS(FBuffer, Polygon, clBlack32); else PolygonFS(FBuffer, Polygon, FVisualAidOptions.Color); end; end; var X, Y: Integer; ScanLine: PColor32Array; Value: Single; LeftColor, RightColor: TColor32Entry; OddY: Boolean; BorderOffset: Integer; GradientFiller: TLinearGradientPolygonFiller; const CByteScale = 1 / 255; CCheckerBoardColor: array [Boolean] of TColor32 = ($FFA0A0A0, $FF5F5F5F); begin FBuffer.Clear(Color32(Color)); BorderOffset := Integer(FBorder); InvertFiller := TInvertPolygonFiller.Create; try LeftColor := TColor32Entry(FSelectedColor); RightColor := TColor32Entry(FSelectedColor); case FColorComponent of ccRed: begin Value := LeftColor.R * CByteScale; LeftColor.R := 0; RightColor.R := 255; LeftColor.A := 255; RightColor.A := 255; end; ccGreen: begin Value := LeftColor.G * CByteScale; LeftColor.G := 0; RightColor.G := 255; LeftColor.A := 255; RightColor.A := 255; end; ccBlue: begin Value := LeftColor.B * CByteScale; LeftColor.B := 0; RightColor.B := 255; LeftColor.A := 255; RightColor.A := 255; end; ccAlpha: begin Value := LeftColor.A * CByteScale; LeftColor.A := 0; RightColor.A := 255; for Y := 0 to Height - 1 do begin OddY := Odd(Y div 8); ScanLine := FBuffer.ScanLine[Y]; for X := 3 to Width - 4 do ScanLine^[X] := CCheckerBoardColor[Odd(X shr 3) = OddY]; end; end; end; GradientFiller := TLinearGradientPolygonFiller.Create; try GradientFiller.SimpleGradientX(3, LeftColor.ARGB, Width - 3, RightColor.ARGB); PolygonFS(FBuffer, Rectangle(FloatRect(3, 0, Width - 3, Height)), GradientFiller); finally GradientFiller.Free; end; if FBorder then begin FBuffer.FrameRectTS(3, 0, Width - 3, Height, $DF000000); FBuffer.RaiseRectTS(4, 0, Width - 4, Height - 1, 20); end; SetLength(Polygon, 3); Polygon[0] := FloatPoint(3 + Value * (Width - 6), Height - BorderOffset - 5); Polygon[1] := FloatPoint(Polygon[0].X - 3, Polygon[0].Y + 5); Polygon[2] := FloatPoint(Polygon[0].X + 3, Polygon[0].Y + 5); RenderPolygon; Polygon[0].Y := BorderOffset + 5; Polygon[1].Y := BorderOffset; Polygon[2].Y := BorderOffset; RenderPolygon; finally InvertFiller.Free; end; inherited; end; procedure TCustomColorPickerComponent.SetColorComponent( const Value: TColorComponent); begin if FColorComponent <> Value then begin FColorComponent := Value; Invalidate; end; end; { TCustomColorPickerRGBA } constructor TCustomColorPickerRGBA.Create(AOwner: TComponent); begin inherited; FBarHeight := 24; FSpaceHeight := 8; FVisualAidOptions.Color := clBlack32; FVisualAidOptions.LineWidth := 1.5; end; procedure TCustomColorPickerRGBA.PickRed(X, Y: Single); var Value: Single; Color: TColor32Entry; begin Value := EnsureRange((X - 3) / (Width - 3), 0, 1); Color := TColor32Entry(SelectedColor); Color.R := Round(Value * 255); SelectedColor := Color.ARGB; end; procedure TCustomColorPickerRGBA.PickGreen(X, Y: Single); var Value: Single; Color: TColor32Entry; begin Value := EnsureRange((X - 3) / (Width - 3), 0, 1); Color := TColor32Entry(SelectedColor); Color.G := Round(Value * 255); SelectedColor := Color.ARGB; end; procedure TCustomColorPickerRGBA.PickBlue(X, Y: Single); var Value: Single; Color: TColor32Entry; begin Value := EnsureRange((X - 3) / (Width - 3), 0, 1); Color := TColor32Entry(SelectedColor); Color.B := Round(Value * 255); SelectedColor := Color.ARGB; end; procedure TCustomColorPickerRGBA.PickAlpha(X, Y: Single); var Value: Single; Color: TColor32Entry; begin Value := EnsureRange((X - 3) / (Width - 3), 0, 1); Color := TColor32Entry(SelectedColor); Color.A := Round(Value * 255); SelectedColor := Color.ARGB; end; procedure TCustomColorPickerRGBA.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Index: Integer; begin if (Button = mbLeft) and (X >= 3) or (X <= Width - 3) then begin Index := Y div (FBarHeight + FSpaceHeight); case Index of 0: FAdjustCalc := PickRed; 1: FAdjustCalc := PickGreen; 2: FAdjustCalc := PickBlue; 3: FAdjustCalc := PickAlpha; end; end; if Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerRGBA.MouseMove(Shift: TShiftState; X, Y: Integer); begin if (ssLeft in Shift) and Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerRGBA.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FAdjustCalc := nil; inherited; end; procedure TCustomColorPickerRGBA.PaintColorPicker; var Polygon: TArrayOfFloatPoint; InvertFiller: TInvertPolygonFiller; procedure RenderPolygon; begin case FVisualAidOptions.RenderType of vatInvert: PolygonFS(FBuffer, Polygon, InvertFiller); vatBW: if Intensity(FSelectedColor) < 127 then PolygonFS(FBuffer, Polygon, clWhite32) else PolygonFS(FBuffer, Polygon, clBlack32); else PolygonFS(FBuffer, Polygon, FVisualAidOptions.Color); end; end; var X, Y, Index: Integer; ScanLine: PColor32Array; Value: Single; LeftColor, RightColor: TColor32Entry; ValueRect: TRect; OddY: Boolean; BorderOffset: Integer; GradientFiller: TLinearGradientPolygonFiller; const CByteScale = 1 / 255; CCheckerBoardColor: array [Boolean] of TColor32 = ($FFA0A0A0, $FF5F5F5F); begin FBuffer.Clear(Color32(Color)); BorderOffset := Integer(FBorder); SetLength(Polygon, 3); InvertFiller := TInvertPolygonFiller.Create; try for Index := 0 to 3 do begin ValueRect := Rect(3, Index * (FBarHeight + FSpaceHeight), Width - 3, Index * (FBarHeight + FSpaceHeight) + FBarHeight); LeftColor := TColor32Entry(FSelectedColor); RightColor := TColor32Entry(FSelectedColor); case Index of 0: begin Value := LeftColor.R * CByteScale; LeftColor.R := 0; RightColor.R := 255; LeftColor.A := 255; RightColor.A := 255; end; 1: begin Value := LeftColor.G * CByteScale; LeftColor.G := 0; RightColor.G := 255; LeftColor.A := 255; RightColor.A := 255; end; 2: begin Value := LeftColor.B * CByteScale; LeftColor.B := 0; RightColor.B := 255; LeftColor.A := 255; RightColor.A := 255; end; 3: begin Value := LeftColor.A * CByteScale; LeftColor.A := 0; RightColor.A := 255; for Y := ValueRect.Top to Min(ValueRect.Bottom, Height) - 1 do begin OddY := Odd(Y div 8); ScanLine := FBuffer.ScanLine[Y]; for X := ValueRect.Left to ValueRect.Right - 1 do ScanLine^[X] := CCheckerBoardColor[Odd(X shr 3) = OddY]; end; end; end; GradientFiller := TLinearGradientPolygonFiller.Create; try GradientFiller.SimpleGradientX(ValueRect.Left, LeftColor.ARGB, ValueRect.Right, RightColor.ARGB); PolygonFS(FBuffer, Rectangle(FloatRect(ValueRect)), GradientFiller); finally GradientFiller.Free; end; if FBorder then begin FBuffer.FrameRectTS(ValueRect, $DF000000); FBuffer.RaiseRectTS(ValueRect.Left + 1, ValueRect.Top + 1, ValueRect.Right - 1, ValueRect.Bottom - 1, 20); end; Polygon[0] := FloatPoint(3 + Value * (Width - 6), ValueRect.Bottom - BorderOffset - 5); Polygon[1] := FloatPoint(Polygon[0].X - 3, Polygon[0].Y + 5); Polygon[2] := FloatPoint(Polygon[0].X + 3, Polygon[0].Y + 5); RenderPolygon; Polygon[0].Y := ValueRect.Top + BorderOffset + 5; Polygon[1].Y := ValueRect.Top + BorderOffset; Polygon[2].Y := ValueRect.Top + BorderOffset; RenderPolygon; end; finally InvertFiller.Free; end; inherited; end; procedure TCustomColorPickerRGBA.SetBarHeight(const Value: Integer); begin if FBarHeight <> Value then begin FBarHeight := Value; Invalidate; end; end; procedure TCustomColorPickerRGBA.SetSpaceHeight(const Value: Integer); begin if FSpaceHeight <> Value then begin FSpaceHeight := Value; Invalidate; end; end; { TCustomColorPickerHS } constructor TCustomColorPickerHS.Create(AOwner: TComponent); var Luminance: Single; begin inherited; FVisualAidOptions.Color := clBlack32; FVisualAidOptions.LineWidth := 1.5; RGBtoHSL(FSelectedColor, FHue, FSaturation, Luminance); end; procedure TCustomColorPickerHS.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then PickHue(X, Y); inherited; end; procedure TCustomColorPickerHS.MouseMove(Shift: TShiftState; X, Y: Integer); begin if (ssLeft in Shift) then PickHue(X, Y); inherited; end; procedure TCustomColorPickerHS.PaintColorPicker; var X, Y: Integer; Saturation, InvWidth, InvHeight: Single; Line: PColor32Array; Pos: TFloatPoint; VectorData: TArrayOfArrayOfFloatPoint; InvertFiller: TInvertPolygonFiller; begin InvWidth := 1 / FBuffer.Width; InvHeight := 1 / FBuffer.Height; if FWebSafe then for Y := 0 to FBuffer.Height - 1 do begin Line := FBuffer.ScanLine[Y]; Saturation := 1 - Y * InvHeight; for X := 0 to FBuffer.Width - 1 do begin Line^[X] := HSLtoRGB(X * InvWidth, Saturation, 0.5); RoundToWebSafe(Line^[X]); end; end else for Y := 0 to FBuffer.Height - 1 do begin Line := FBuffer.ScanLine[Y]; Saturation := 1 - Y * InvHeight; for X := 0 to FBuffer.Width - 1 do Line^[X] := HSLtoRGB(X * InvWidth, Saturation, 0.5); end; Pos.X := Round(FHue * FBuffer.Width); Pos.Y := Round((1 - FSaturation) * FBuffer.Height); case FMarkerType of mtCross: begin SetLength(VectorData, 4); VectorData[0] := HorzLine(Pos.X - 5, Pos.Y, Pos.X - 2); VectorData[1] := HorzLine(Pos.X + 2, Pos.Y, Pos.X + 5); VectorData[2] := VertLine(Pos.X, Pos.Y - 5, Pos.Y - 2); VectorData[3] := VertLine(Pos.X, Pos.Y + 2, Pos.Y + 5); case FVisualAidOptions.RenderType of vatSolid: PolyPolylineFS(FBuffer, VectorData, FVisualAidOptions.Color, False, FVisualAidOptions.LineWidth); vatInvert: begin InvertFiller := TInvertPolygonFiller.Create; try PolyPolylineFS(FBuffer, VectorData, InvertFiller, False, FVisualAidOptions.LineWidth) finally InvertFiller.Free; end; end; vatBW: PolyPolylineFS(FBuffer, VectorData, FVisualAidOptions.Color, False, FVisualAidOptions.LineWidth); end; end; mtCircle: begin SetLength(VectorData, 1); VectorData[0] := Circle(Pos, 4, 12); PolygonFS(FBuffer, VectorData[0], FSelectedColor); case FVisualAidOptions.RenderType of vatSolid: PolylineFS(FBuffer, VectorData[0], FVisualAidOptions.Color, True, FVisualAidOptions.LineWidth); vatInvert: begin InvertFiller := TInvertPolygonFiller.Create; try PolylineFS(FBuffer, VectorData[0], InvertFiller, True, 1.5) finally InvertFiller.Free; end; end; vatBW: PolylineFS(FBuffer, VectorData[0], FVisualAidOptions.Color, True, 1.5); end; end; end; end; procedure TCustomColorPickerHS.PickHue(X, Y: Single); begin FHue := EnsureRange(X / FBuffer.Width, 0, 1); FSaturation := EnsureRange(1 - Y / FBuffer.Height, 0, 1); SelectedColor := SetAlpha(HSLtoRGB(FHue, FSaturation, 0.5), SelectedColor shr 24); end; procedure TCustomColorPickerHS.SelectedColorChanged; var H, S, L: Single; begin RGBtoHSL(FSelectedColor, H, S, L); if not (pcHue in FPreserveComponent) then FHue := H; if not (pcSaturation in FPreserveComponent) then FSaturation := S; FPreserveComponent := []; inherited; end; procedure TCustomColorPickerHS.SetHue(const Value: Single); begin if FHue <> Value then begin FHue := Value; FPreserveComponent := FPreserveComponent + [pcHue]; SelectedColor := SetAlpha(HSLtoRGB(FHue, FSaturation, 1), SelectedColor shr 24); end; end; procedure TCustomColorPickerHS.SetSaturation(const Value: Single); begin if FSaturation <> Value then begin FSaturation := Value; FPreserveComponent := FPreserveComponent + [pcSaturation]; SelectedColor := SetAlpha(HSLtoRGB(FHue, FSaturation, 1), SelectedColor shr 24); end; end; procedure TCustomColorPickerHS.SetMarkerType(const Value: TMarkerType); begin if FMarkerType <> Value then begin FMarkerType := Value; Invalidate; end; end; { TCustomColorPickerHSV } constructor TCustomColorPickerHSV.Create(AOwner: TComponent); begin inherited Create(AOwner); FVisualAid := [vaHueLine, vaSaturationCircle, vaSelection]; FVisualAidOptions.LineWidth := 1.5; RGBToHSV(FSelectedColor, FHue, FSaturation, FValue); { Setting a initial size here will cause the control to crash under LCL } {$IFNDEF FPC} Height := 192; Width := 256; {$ENDIF} end; procedure TCustomColorPickerHSV.PaintColorPicker; var Polygon: TArrayOfFloatPoint; ValueRect: TRect; GradientFiller: TLinearGradientPolygonFiller; HueSaturationFiller: THueSaturationCirclePolygonFiller; InvertFiller: TInvertPolygonFiller; LineWidth: Single; begin FBuffer.Clear(Color32(Color)); Polygon := Circle(FCenter, FRadius, FCircleSteps); HueSaturationFiller := THueSaturationCirclePolygonFiller.Create(FCenter, FRadius, FValue, FWebSafe); try PolygonFS(FBuffer, Polygon, HueSaturationFiller); finally HueSaturationFiller.Free; end; if FBorder then PolylineFS(FBuffer, Polygon, clBlack32, True, 1); LineWidth := FVisualAidOptions.LineWidth; InvertFiller := TInvertPolygonFiller.Create; try if vaSaturationCircle in FVisualAid then begin Polygon := Circle(FCenter, FSaturation * FRadius, -1); case FVisualAidOptions.RenderType of vatInvert: PolylineFS(FBuffer, Polygon, InvertFiller, True, LineWidth); vatBW: if Intensity(FSelectedColor) < 127 then PolylineFS(FBuffer, Polygon, clWhite32, True, LineWidth) else PolylineFS(FBuffer, Polygon, clBlack32, True, LineWidth); else PolylineFS(FBuffer, Polygon, FVisualAidOptions.Color, True, LineWidth); end; end; if vaHueLine in FVisualAid then begin SetLength(Polygon, 2); Polygon[0] := FCenter; Polygon[1] := FloatPoint( FCenter.X - FRadius * Cos(2 * Pi * FHue), FCenter.Y - FRadius * Sin(2 * Pi * FHue)); case FVisualAidOptions.RenderType of vatInvert: PolylineFS(FBuffer, Polygon, InvertFiller, False, LineWidth); vatBW: if Intensity(FSelectedColor) < 127 then PolylineFS(FBuffer, Polygon, clWhite32, False, LineWidth) else PolylineFS(FBuffer, Polygon, clBlack32, False, LineWidth); else PolylineFS(FBuffer, Polygon, FVisualAidOptions.Color, False, LineWidth); end; end; if vaSelection in FVisualAid then begin Polygon := Circle( FCenter.X - FSaturation * FRadius * Cos(2 * Pi * FHue), FCenter.Y - FSaturation * FRadius * Sin(2 * Pi * FHue), 4, 8); PolygonFS(FBuffer, Polygon, FSelectedColor); case FVisualAidOptions.RenderType of vatInvert: PolylineFS(FBuffer, Polygon, InvertFiller, True, LineWidth); vatBW: if Intensity(FSelectedColor) < 127 then PolylineFS(FBuffer, Polygon, clWhite32, True, LineWidth) else PolylineFS(FBuffer, Polygon, clBlack32, True, LineWidth); else PolylineFS(FBuffer, Polygon, FVisualAidOptions.Color, True, LineWidth); end; end; ValueRect := Rect(Width - 24, 8, Width - 8, Height - 8); Polygon := Rectangle(FloatRect(ValueRect)); GradientFiller := TLinearGradientPolygonFiller.Create; try GradientFiller.SimpleGradientY(ValueRect.Top, clWhite32, ValueRect.Bottom, clBlack32); PolygonFS(FBuffer, Polygon, GradientFiller); finally GradientFiller.Free; end; SetLength(Polygon, 3); Polygon[0] := FloatPoint(Width - 8, 8 + (1 - FValue) * (Height - 16)); Polygon[1] := FloatPoint(Polygon[0].X + 7, Polygon[0].Y - 4); Polygon[2] := FloatPoint(Polygon[0].X + 7, Polygon[0].Y + 4); case FVisualAidOptions.RenderType of vatInvert: PolygonFS(FBuffer, Polygon, InvertFiller); vatBW: if Intensity(FSelectedColor) < 127 then PolygonFS(FBuffer, Polygon, clWhite32) else PolygonFS(FBuffer, Polygon, clBlack32); else PolygonFS(FBuffer, Polygon, FVisualAidOptions.Color); end; if FBorder then begin FBuffer.FrameRectTS(ValueRect, $DF000000); FBuffer.RaiseRectTS(ValueRect.Left + 1, ValueRect.Top + 1, ValueRect.Right - 1, ValueRect.Bottom - 1, 20); end; finally InvertFiller.Free; end; inherited; end; procedure TCustomColorPickerHSV.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then begin if X > Width - 28 then FAdjustCalc := PickValue else FAdjustCalc := PickHue; end; if Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerHSV.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FAdjustCalc := nil; inherited; end; procedure TCustomColorPickerHSV.MouseMove(Shift: TShiftState; X, Y: Integer); begin if (ssLeft in Shift) and Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerHSV.Resize; begin inherited; if Height < Width then begin FRadius := Min(0.5 * Width - 1 - 16, 0.5 * Height - 1); FCircleSteps := CalculateCircleSteps(FRadius); FCenter := FloatPoint(0.5 * Width - 16, 0.5 * Height); end else begin FRadius := Min(0.5 * Width - 1, 0.5 * Height - 1 - 16); FCircleSteps := CalculateCircleSteps(FRadius); FCenter := FloatPoint(0.5 * Width, 0.5 * Height - 16); end; end; procedure TCustomColorPickerHSV.PickHue(X, Y: Single); const CTwoPiInv = 1 / (2 * Pi); begin FHue := 0.5 + ArcTan2(Y - FCenter.Y, X - FCenter.X) * CTwoPiInv; FSaturation := Sqrt(Sqr(Y - FCenter.Y) + Sqr(X - FCenter.X)) / FRadius; if FSaturation > 1 then FSaturation := 1; FPreserveComponent := FPreserveComponent + [pcSaturation, pcHue]; SelectedColor := SetAlpha(HSVtoRGB(FHue, FSaturation, FValue), SelectedColor shr 24); end; procedure TCustomColorPickerHSV.PickValue(X, Y: Single); begin Value := 1 - EnsureRange((Y - 8) / (Height - 16), 0, 1); end; procedure TCustomColorPickerHSV.SetHue(const Value: Single); begin if FHue <> Value then begin FHue := Value; FPreserveComponent := FPreserveComponent + [pcHue]; SelectedColor := SetAlpha(HSVtoRGB(FHue, FSaturation, FValue), SelectedColor shr 24); end; end; procedure TCustomColorPickerHSV.SetSaturation(const Value: Single); begin if FSaturation <> Value then begin FSaturation := Value; FPreserveComponent := FPreserveComponent + [pcSaturation]; SelectedColor := SetAlpha(HSVtoRGB(FHue, FSaturation, FValue), SelectedColor shr 24); end; end; procedure TCustomColorPickerHSV.SelectedColorChanged; var H, S, V: Single; begin RGBtoHSV(FSelectedColor, H, S, V); if not (pcHue in FPreserveComponent) then FHue := H; if not (pcSaturation in FPreserveComponent) then FSaturation := S; if not (pcValue in FPreserveComponent) then FValue := V; FPreserveComponent := []; inherited; end; procedure TCustomColorPickerHSV.SetValue(const Value: Single); begin if FValue <> Value then begin FValue := Value; FPreserveComponent := FPreserveComponent + [pcValue]; SelectedColor := SetAlpha(HSVtoRGB(FHue, FSaturation, FValue), SelectedColor shr 24); end; end; procedure TCustomColorPickerHSV.SetVisualAid(const Value: TVisualAid); begin if FVisualAid <> Value then begin FVisualAid := Value; Invalidate; end; end; { TCustomColorPickerGTK } constructor TCustomColorPickerGTK.Create(AOwner: TComponent); begin inherited Create(AOwner); FVisualAid := [vagHueLine, vagSelection]; FVisualAidOptions.RenderType := vatBW; FVisualAidOptions.LineWidth := 2; RGBToHSV(FSelectedColor, FHue, FSaturation, FValue); { Setting a initial size here will cause the control to crash under LCL } {$IFNDEF FPC} Height := 192; Width := 192; {$ENDIF} end; procedure TCustomColorPickerGTK.PaintColorPicker; var Polygon: TArrayOfFloatPoint; HueBand: TArrayOfArrayOfFloatPoint; GradientFiller: TBarycentricGradientPolygonFillerEx; HueFiller: THueCirclePolygonFiller; InvertFiller: TInvertPolygonFiller; Pos: TFloatPoint; HalfInnerRadius: Single; LineWidth: Single; const CY = 1.7320508075688772935274463415059; begin FBuffer.Clear(Color32(Color)); Polygon := Circle(FCenter, 0.5 * (FRadius + FInnerRadius), FCircleSteps); HueBand := BuildPolyPolyline(PolyPolygon(Polygon), True, FRadius - FInnerRadius); HueFiller := THueCirclePolygonFiller.Create(FCenter, FWebSafe); try PolyPolygonFS(FBuffer, HueBand, HueFiller); finally HueFiller.Free; end; LineWidth := FVisualAidOptions.LineWidth; if vagHueLine in FVisualAid then begin SetLength(Polygon, 2); Polygon[0] := FloatPoint( FCenter.X - FInnerRadius * Cos(2 * Pi * FHue), FCenter.Y - FInnerRadius * Sin(2 * Pi * FHue)); Polygon[1] := FloatPoint( FCenter.X - FRadius * Cos(2 * Pi * FHue), FCenter.Y - FRadius * Sin(2 * Pi * FHue)); case FVisualAidOptions.RenderType of vatSolid: PolylineFS(FBuffer, Polygon, FVisualAidOptions.Color, False, LineWidth); vatInvert: begin InvertFiller := TInvertPolygonFiller.Create; try PolylineFS(FBuffer, Polygon, InvertFiller, False, LineWidth); finally InvertFiller.Free; end; end; vatBW: if Intensity(HSVtoRGB(FHue, 1, 1)) < 127 then PolylineFS(FBuffer, Polygon, $F0FFFFFF, True, LineWidth) else PolylineFS(FBuffer, Polygon, $F0000000, True, LineWidth) end; end; GR32_Math.SinCos(2 * Pi * FHue, Pos.Y, Pos.X); SetLength(Polygon, 3); Polygon[0] := FloatPoint( FCenter.X - FInnerRadius * Pos.X, FCenter.Y - FInnerRadius * Pos.Y); HalfInnerRadius := 0.5 * FInnerRadius; Pos := FloatPoint(Pos.X + CY * Pos.Y, Pos.X * CY - Pos.Y); Polygon[1] := FloatPoint( FCenter.X + HalfInnerRadius * Pos.X, FCenter.Y - HalfInnerRadius * Pos.Y); HalfInnerRadius := 0.5 * HalfInnerRadius; Pos := FloatPoint(Pos.X - CY * Pos.Y, Pos.Y + Pos.X * CY); Polygon[2] := FloatPoint( FCenter.X - HalfInnerRadius * Pos.X, FCenter.Y + HalfInnerRadius * Pos.Y); GradientFiller := TBarycentricGradientPolygonFillerEx.Create; try GradientFiller.SetPoints(Polygon); GradientFiller.Color[0] := HSVtoRGB(Hue, 1, 1); GradientFiller.Color[1] := clWhite32; GradientFiller.Color[2] := clBlack32; GradientFiller.WebSafe := FWebSafe; PolygonFS(FBuffer, Polygon, GradientFiller); finally GradientFiller.Free; end; if FBorder then begin PolyPolygonFS(FBuffer, BuildPolyPolyline(HueBand, True, 1), clBlack32); PolylineFS(FBuffer, Polygon, clBlack32, True, 1); end; if vagSelection in FVisualAid then begin Polygon := Circle( Polygon[2].X + FValue * (Polygon[1].X + FSaturation * (Polygon[0].X - Polygon[1].X) - Polygon[2].X), Polygon[2].Y + FValue * (Polygon[1].Y + FSaturation * (Polygon[0].Y - Polygon[1].Y) - Polygon[2].Y), 4, 12); PolygonFS(FBuffer, Polygon, FSelectedColor); case FVisualAidOptions.RenderType of vatSolid: PolylineFS(FBuffer, Polygon, FVisualAidOptions.Color, True, LineWidth); vatInvert: begin InvertFiller := TInvertPolygonFiller.Create; try PolylineFS(FBuffer, Polygon, InvertFiller, True, LineWidth); finally InvertFiller.Free; end; end; vatBW: if Intensity(FSelectedColor) < 127 then PolylineFS(FBuffer, Polygon, clWhite32, True, LineWidth) else PolylineFS(FBuffer, Polygon, clBlack32, True, LineWidth) end end; inherited; end; procedure TCustomColorPickerGTK.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then begin if Sqrt(Sqr(X - FCenter.X) + Sqr(Y - FCenter.Y)) > FInnerRadius then FAdjustCalc := PickHue else FAdjustCalc := PickSaturationValue; end; if Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerGTK.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FAdjustCalc := nil; inherited; end; procedure TCustomColorPickerGTK.MouseMove(Shift: TShiftState; X, Y: Integer); begin if (ssLeft in Shift) and Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerGTK.Resize; begin inherited; Radius := Min(0.5 * Width - 1, 0.5 * Height - 1); Center := FloatPoint(0.5 * Width, 0.5 * Height); end; procedure TCustomColorPickerGTK.PickHue(X, Y: Single); const CTwoPiInv = 1 / (2 * Pi); begin Hue := 0.5 + ArcTan2(Y - FCenter.Y, X - FCenter.X) * CTwoPiInv; FPreserveComponent := FPreserveComponent + [pcHue]; end; procedure TCustomColorPickerGTK.PickSaturationValue(X, Y: Single); var Pos: TFloatPoint; const CY = 1.7320508075688772935274463415059; begin with TBarycentricGradientSampler.Create do try GR32_Math.SinCos(2 * Pi * FHue, Pos.Y, Pos.X); Point[0] := FloatPoint( FCenter.X - FInnerRadius * Pos.X, FCenter.Y - FInnerRadius * Pos.Y); Pos := FloatPoint(-0.5 * (Pos.X + CY * Pos.Y), 0.5 * (Pos.X * CY - Pos.Y)); Point[1] := FloatPoint( FCenter.X - FInnerRadius * Pos.X, FCenter.Y - FInnerRadius * Pos.Y); Pos := FloatPoint(-0.5 * (Pos.X + CY * Pos.Y), 0.5 * (Pos.X * CY - Pos.Y)); Point[2] := FloatPoint( FCenter.X - FInnerRadius * Pos.X, FCenter.Y - FInnerRadius * Pos.Y); Color[0] := HSVtoRGB(Hue, 1, 1); Color[1] := clWhite32; Color[2] := clBlack32; PrepareSampling; FPreserveComponent := FPreserveComponent + [pcHue]; SelectedColor := SetAlpha(GetSampleFloatInTriangle(X, Y), SelectedColor shr 24); finally Free; end; end; procedure TCustomColorPickerGTK.SetHue(const Value: Single); begin if FHue <> Value then begin FHue := Value; FPreserveComponent := FPreserveComponent + [pcHue]; SelectedColor := SetAlpha(HSVtoRGB(FHue, FSaturation, FValue), SelectedColor shr 24); end; end; procedure TCustomColorPickerGTK.SetRadius(const Value: TFloat); begin if FRadius <> Value then begin FRadius := Value; FInnerRadius := 0.8 * FRadius; FCircleSteps := CalculateCircleSteps(FRadius); end; end; procedure TCustomColorPickerGTK.SetSaturation(const Value: Single); begin if FSaturation <> Value then begin FSaturation := Value; FPreserveComponent := FPreserveComponent + [pcSaturation]; SelectedColor := SetAlpha(HSVtoRGB(FHue, FSaturation, FValue), SelectedColor shr 24); end; end; procedure TCustomColorPickerGTK.SelectedColorChanged; var H, S, V: Single; begin RGBtoHSV(FSelectedColor, H, S, V); if not (pcHue in FPreserveComponent) then FHue := H; if not (pcSaturation in FPreserveComponent) then FSaturation := S; if not (pcValue in FPreserveComponent) then FValue := V; FPreserveComponent := []; inherited; end; procedure TCustomColorPickerGTK.SetValue(const Value: Single); begin if FValue <> Value then begin FValue := Value; FPreserveComponent := FPreserveComponent + [pcValue]; SelectedColor := SetAlpha(HSVtoRGB(FHue, FSaturation, FValue), SelectedColor shr 24); end; end; procedure TCustomColorPickerGTK.SetVisualAid(const Value: TVisualAidGTK); begin if FVisualAid <> Value then begin FVisualAid := Value; Invalidate; end; end; end. |
Added src/graphics32/GR32_ColorSwatch.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 | unit GR32_ColorSwatch; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Christan-W. Budde <Christian@savioursofsoul.de> * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LCLType, LMessages, Types, {$IFDEF MSWINDOWS} Windows, {$ENDIF} {$ELSE} Windows, Messages, {$ENDIF} Classes, Controls, Forms, GR32, GR32_Containers; type TCustomColorSwatch = class(TCustomControl) private FBuffer: TBitmap32; FColor: TColor32; FBufferValid: Boolean; FBorder: Boolean; procedure SetBorder(const Value: Boolean); procedure SetColor(const Value: TColor32); {$IFDEF FPC} procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; procedure WMGetDlgCode(var Msg: TLMessage); message LM_GETDLGCODE; {$ELSE} procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND; procedure WMGetDlgCode(var Msg: TWmGetDlgCode); message WM_GETDLGCODE; {$ENDIF} protected procedure Paint; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Invalidate; override; procedure Resize; override; property Border: Boolean read FBorder write SetBorder default False; property Color: TColor32 read FColor write SetColor; end; TColorSwatch = class(TCustomColorSwatch) published property Align; property Anchors; property Border; property Color; property DragCursor; property DragKind; property Enabled; {$IFNDEF FPC} property ParentBackground; {$ENDIF} property ParentColor; property ParentShowHint; property PopupMenu; property TabOrder; property TabStop; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; {$IFDEF COMPILER2005_UP} property OnMouseEnter; property OnMouseLeave; {$ENDIF} property OnResize; property OnStartDrag; end; implementation uses Math, Graphics, GR32_Backends, GR32_Math, GR32_Blend, GR32_VectorUtils; { TCustomColorSwatch } constructor TCustomColorSwatch.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csOpaque]; FBuffer := TBitmap32.Create; FColor := clSalmon32; end; destructor TCustomColorSwatch.Destroy; begin FBuffer.Free; inherited; end; procedure TCustomColorSwatch.Invalidate; begin FBufferValid := False; inherited; end; procedure TCustomColorSwatch.Paint; var X, Y: Integer; OddY: Boolean; ScanLine: PColor32Array; const CCheckerBoardColor: array [Boolean] of TColor32 = ($FFA0A0A0, $FF5F5F5F); begin if not Assigned(Parent) then Exit; if not FBufferValid then begin (FBuffer.Backend as IPaintSupport).ImageNeeded; // draw checker board if not (FColor and $FF000000 = $FF000000) then begin Y := 0; while Y < FBuffer.Height do begin ScanLine := FBuffer.Scanline[Y]; OddY := Odd(Y shr 2); for X := 0 to FBuffer.Width - 1 do ScanLine[X] := CCheckerBoardColor[Odd(X shr 2) = OddY]; Inc(Y); end; end; // draw color FBuffer.FillRectT(0, 0, FBuffer.Width, FBuffer.Height, FColor); // eventually draw border if FBorder then begin FBuffer.FrameRectTS(0, 0, FBuffer.Width, FBuffer.Height, $DF000000); FBuffer.RaiseRectTS(1, 1, FBuffer.Width - 1, FBuffer.Height - 1, 20); end; (FBuffer.Backend as IPaintSupport).CheckPixmap; FBufferValid := True; end; FBuffer.Lock; with Canvas do try (FBuffer.Backend as IDeviceContextSupport).DrawTo(Canvas.Handle, 0, 0); finally FBuffer.Unlock; end; end; procedure TCustomColorSwatch.Resize; begin inherited; FBuffer.SetSize(Width, Height); FBufferValid := False; end; procedure TCustomColorSwatch.SetBorder(const Value: Boolean); begin if FBorder <> Value then begin FBorder := Value; Invalidate; end; end; procedure TCustomColorSwatch.SetColor(const Value: TColor32); begin if FColor <> Value then begin FColor := Value; Invalidate; end; end; procedure TCustomColorSwatch.WMEraseBkgnd(var Message: {$IFDEF FPC}TLmEraseBkgnd{$ELSE}TWmEraseBkgnd{$ENDIF}); begin Message.Result := 1; end; procedure TCustomColorSwatch.WMGetDlgCode(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TWmGetDlgCode{$ENDIF}); begin with Msg do Result := Result or DLGC_WANTARROWS; end; end. |
Added src/graphics32/GR32_Compiler.inc.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 | (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Andre Beckedorf <Andre@metaException.de> * Michael Hansen <dyster_tid@hotmail.com> * Christian Budde <Christian@aixcoustic.com> * * ***** END LICENSE BLOCK ***** *) (* Available Compilers: -------------------- COMPILERFPC - FPC (since version 2.6.0) COMPILER6 - Delphi 6 COMPILER7 - Delphi 7 COMPILER2005 - Delphi 2005 COMPILER2006 - Delphi 2006 / BDS 2006 COMPILER2007 - Delphi / RAD Studio 2007 COMPILER2009 - Delphi 2009 COMPILER2010 - Delphi 2010 COMPILERXE1 - Delphi XE COMPILERXE2 - Delphi XE2 COMPILERXE3 - Delphi XE3 COMPILERXE4 - Delphi XE4 COMPILERXE5 - Delphi XE5 COMPILERXE6 - Delphi XE6 COMPILERXE7 - Delphi XE7 COMPILERXE8 - Delphi XE8 COMPILERRX - Delphi RX COMPILERRX1 - Delphi RX1 COMPILERRX2 - Delphi RX2 (10.2 Tokyo) Available Targets: ------------------ TARGET_x86 - x86 (32-Bit) TARGET_x64 - x86 (64-Bit) TARGET_POWERPC - Power PC *) {$IFDEF FPC} {$DEFINE COMPILERFPC} {$ENDIF} {$IFDEF VER_LATEST} // adjust for newer version (always use latest version) {$DEFINE COMPILERRX2} {$IFNDEF BCB} {$DEFINE DELPHIRX2} {$ELSE} {$DEFINE BCBRX2} {$ENDIF} {$UNDEF VER_LATEST} {$ENDIF} {$IFDEF VER320} {$DEFINE COMPILERRX2} {$IFNDEF BCB} {$DEFINE DELPHIRX2} {$ELSE} {$DEFINE BCBRX2} {$ENDIF} {$ENDIF} {$IFDEF VER310} {$DEFINE COMPILERRX1} {$IFNDEF BCB} {$DEFINE DELPHIRX1} {$ELSE} {$DEFINE BCBRX1} {$ENDIF} {$ENDIF} {$IFDEF VER300} {$DEFINE COMPILERRX} {$IFNDEF BCB} {$DEFINE DELPHIRX} {$ELSE} {$DEFINE BCBRX} {$ENDIF} {$ENDIF} {$IFDEF VER290} {$DEFINE COMPILERXE8} {$IFNDEF BCB} {$DEFINE DELPHIXE8} {$ELSE} {$DEFINE BCBXE8} {$ENDIF} {$ENDIF} {$IFDEF VER280} {$DEFINE COMPILERXE7} {$IFNDEF BCB} {$DEFINE DELPHIXE7} {$ELSE} {$DEFINE BCBXE7} {$ENDIF} {$ENDIF} {$IFDEF VER270} {$DEFINE COMPILERXE6} {$IFNDEF BCB} {$DEFINE DELPHIXE6} {$ELSE} {$DEFINE BCBXE6} {$ENDIF} {$ENDIF} {$IFDEF VER260} {$DEFINE COMPILERXE5} {$IFNDEF BCB} {$DEFINE DELPHIXE5} {$ELSE} {$DEFINE BCBXE5} {$ENDIF} {$ENDIF} {$IFDEF VER250} {$DEFINE COMPILERXE4} {$IFNDEF BCB} {$DEFINE DELPHIXE4} {$ELSE} {$DEFINE BCBXE4} {$ENDIF} {$ENDIF} {$IFDEF VER240} {$DEFINE COMPILERXE3} {$IFNDEF BCB} {$DEFINE DELPHIXE3} {$ELSE} {$DEFINE BCBXE3} {$ENDIF} {$ENDIF} {$IFDEF VER230} {$DEFINE COMPILERXE2} {$IFNDEF BCB} {$DEFINE DELPHIXE2} {$ELSE} {$DEFINE BCBXE2} {$ENDIF} {$ENDIF} {$IFDEF VER220} {$DEFINE COMPILERXE1} {$IFNDEF BCB} {$DEFINE DELPHIXE1} {$ELSE} {$DEFINE BCBXE1} {$ENDIF} {$ENDIF} {$IFDEF VER210} {$DEFINE COMPILER2010} {$IFNDEF BCB} {$DEFINE DELPHI2010} {$ELSE} {$DEFINE BCB14} {$ENDIF} {$ENDIF} {$IFDEF VER200} {$DEFINE COMPILER2009} {$IFNDEF BCB} {$DEFINE DELPHI2009} {$ELSE} {$DEFINE BCB12} {$ENDIF} {$ENDIF} {$IFDEF VER185} {$DEFINE COMPILER2007} {$IFNDEF BCB} {$DEFINE DELPHI2007} {$ELSE} {$DEFINE BCB11} {$ENDIF} {$ENDIF} {$IFDEF VER180} {$DEFINE COMPILER2006} {$IFNDEF BCB} {$DEFINE DELPHI2006} {$ELSE} {$DEFINE BCB10} {$ENDIF} {$ENDIF} {$IFDEF VER170} {$DEFINE COMPILER2005} {$IFNDEF BCB} {$DEFINE DELPHI2005} {$ELSE} {$DEFINE BCB8} {$ENDIF} {$ENDIF} {$IFDEF VER150} {$DEFINE COMPILER7} {$IFNDEF BCB} {$DEFINE DELPHI7} {$ELSE} {$DEFINE BCB7} {$ENDIF} {$ENDIF} {$IFDEF VER140} {$DEFINE COMPILER6} {$IFNDEF BCB} {$DEFINE DELPHI6} {$ELSE} {$DEFINE BCB6} {$ENDIF} {$ENDIF} {$IFDEF COMPILERRX2} {$DEFINE COMPILERRX2_UP} {$DEFINE COMPILERRX1_UP} {$DEFINE COMPILERRX_UP} {$DEFINE COMPILERXE8_UP} {$DEFINE COMPILERXE7_UP} {$DEFINE COMPILERXE6_UP} {$DEFINE COMPILERXE5_UP} {$DEFINE COMPILERXE4_UP} {$DEFINE COMPILERXE3_UP} {$DEFINE COMPILERXE2_UP} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERRX1} {$DEFINE COMPILERRX1_UP} {$DEFINE COMPILERRX_UP} {$DEFINE COMPILERXE8_UP} {$DEFINE COMPILERXE7_UP} {$DEFINE COMPILERXE6_UP} {$DEFINE COMPILERXE5_UP} {$DEFINE COMPILERXE4_UP} {$DEFINE COMPILERXE3_UP} {$DEFINE COMPILERXE2_UP} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERRX} {$DEFINE COMPILERRX_UP} {$DEFINE COMPILERXE8_UP} {$DEFINE COMPILERXE7_UP} {$DEFINE COMPILERXE6_UP} {$DEFINE COMPILERXE5_UP} {$DEFINE COMPILERXE4_UP} {$DEFINE COMPILERXE3_UP} {$DEFINE COMPILERXE2_UP} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERXE8} {$DEFINE COMPILERXE8_UP} {$DEFINE COMPILERXE7_UP} {$DEFINE COMPILERXE6_UP} {$DEFINE COMPILERXE5_UP} {$DEFINE COMPILERXE4_UP} {$DEFINE COMPILERXE3_UP} {$DEFINE COMPILERXE2_UP} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERXE7} {$DEFINE COMPILERXE7_UP} {$DEFINE COMPILERXE6_UP} {$DEFINE COMPILERXE5_UP} {$DEFINE COMPILERXE4_UP} {$DEFINE COMPILERXE3_UP} {$DEFINE COMPILERXE2_UP} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERXE6} {$DEFINE COMPILERXE6_UP} {$DEFINE COMPILERXE5_UP} {$DEFINE COMPILERXE4_UP} {$DEFINE COMPILERXE3_UP} {$DEFINE COMPILERXE2_UP} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERXE5} {$DEFINE COMPILERXE5_UP} {$DEFINE COMPILERXE4_UP} {$DEFINE COMPILERXE3_UP} {$DEFINE COMPILERXE2_UP} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERXE4} {$DEFINE COMPILERXE4_UP} {$DEFINE COMPILERXE3_UP} {$DEFINE COMPILERXE2_UP} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERXE3} {$DEFINE COMPILERXE3_UP} {$DEFINE COMPILERXE2_UP} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERXE2} {$DEFINE COMPILERXE2_UP} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERXE1} {$DEFINE COMPILERXE1_UP} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILER2010} {$DEFINE COMPILER2010_UP} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILER2009} {$DEFINE COMPILER2009_UP} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILER2007} {$DEFINE COMPILER2007_UP} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILER2006} {$DEFINE COMPILER2006_UP} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILER2005} {$DEFINE COMPILER2005_UP} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILER7} {$DEFINE COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILER6} {$DEFINE COMPILER6_UP} {$ENDIF} {$IFDEF COMPILERFPC} {$DEFINE PLATFORM_INDEPENDENT} {$MODE Delphi} {$ENDIF} {$IFDEF COMPILERXE2_UP} {$IFDEF TARGET_x64} {$EXCESSPRECISION OFF} {$ENDIF} {$ENDIF} {$IFNDEF COMPILER6_UP} {$IFNDEF COMPILERFPC} +--------------------------------------------------------------------+ | Graphics32 may only be installed with Delphi/BCB 6 (or higher) | | or Free Pascal / Lazarus | +--------------------------------------------------------------------+ {$ENDIF} {$ENDIF} (* Symbol INLININGSUPPORTED: ------------------------- In later Delphi versions procedures and functions that do not contain assembler code can be inlined. This can be extremely useful for calls to a small portion of code in a loop. However, depending on the instruction cache size, this may or may not result in a performance boost compared to a call of assembler optimized code. *) {$IFDEF COMPILER2007_UP} // disabled prior Delphi versions due to a compiler bug // see (http://qc.embarcadero.com/wc/qcmain.aspx?d=41166) {$DEFINE INLININGSUPPORTED} {$ENDIF} {$IFDEF COMPILERFPC} {$DEFINE INLININGSUPPORTED} {$ENDIF} (* Symbol TARGET_* : Defines the processor platform (x86, x64 or PowerPC) *) {$IFDEF COMPILERFPC} // Set up internal CPU target directives according to FPC directives {$IFDEF CPU386} {$IFDEF CPUI386} // target is an Intel 80386 or later. {$DEFINE TARGET_x86} {$ASMMODE INTEL} {$ENDIF} {$IFDEF CPUX86_64} // target is a 64-bit processor (AMD or INTEL). {$DEFINE TARGET_x64} {$ASMMODE INTEL} {$ENDIF} {$IFDEF CPUPOWERPC} // target is a 32-bit PowerPC or compatible. // currently only indirect support, added here as example on how to add // future specific targets {$DEFINE TARGET_POWERPC} {$ENDIF} {$ENDIF} {$IFDEF CPUX86_64} // target is a 64-bit processor (AMD or INTEL). {$DEFINE TARGET_x64} {$ASMMODE INTEL} {$ENDIF} {$IFDEF CPUARM} // target is an ARM processor. {$DEFINE TARGET_ARM} {$ENDIF} {$ELSE} // check for XE2 64-Bit compiler define {$IFDEF CPUX64} {$DEFINE TARGET_x64} {$ELSE} // define default (delphi etc) target (32 bit Intel 80386 or later) {$DEFINE TARGET_x86} {$ENDIF} {$ENDIF} (* Symbol BITS_GETTER: ------------------- *) {$IFDEF COMPILERFPC} // Widgetsets other then Windows will want to implement BITS_GETTER {$IFNDEF LCLWin32} {$DEFINE BITS_GETTER} {$ENDIF} {$ENDIF} (* Symbol PUREPASCAL: ------------------ Forces GR32 into pure pascal mode. NOTE: Further work needed to make assembly routines FPC compatible. NOTE: The DARWIN target of Free Pascal generates PIC code by default Which isn't compatible with the current assembler, so force PUREPASCAL NOTE: Due to several issues with the Delphi X64 compiler, PUREPASCAL is defined. However, most of the assembler optimized code does already work. (for issues please see http://qc.embarcadero.com/wc/qcmain.aspx?d=98616 and http://qc.embarcadero.com/wc/qcmain.aspx?d=98613) *) {$IFDEF COMPILERFPC} {-$DEFINE PUREPASCAL} {$ENDIF} {$IFDEF TARGET_x64} {-$DEFINE PUREPASCAL} {$ENDIF} {$IFDEF TARGET_ARM} {$DEFINE PUREPASCAL} {$DEFINE OMIT_MMX} {$DEFINE OMIT_SSE2} {$ENDIF} {$IFDEF DARWIN} {$DEFINE PUREPASCAL} {$ENDIF} (* Symbol BITS_GETTER: ------------------- *) {$IFDEF COMPILERFPC} // Widgetsets other then Windows will want to implement BITS_GETTER {$IFNDEF LCLWin32} {$DEFINE BITS_GETTER} {$ENDIF} {$ENDIF} (* Symbol NATIVE_SINCOS: --------------------- Use native FPU function to retrieve SIN/COS values for a given argument NOTE: On older systems a native call is typically much faster than calling Sin() and Cos() from a higher level library (such as the math/system unit) separately. However, on 64-bit systems a call can be slower, due to additional conversion between XMM registers and the FPU *) {$IFDEF PUREPASCAL} {$DEFINE NATIVE_SINCOS} {$ENDIF} {$IFDEF TARGET_x64} {$DEFINE NATIVE_SINCOS} {$ENDIF} (* Symbol HAS_NATIVEINT: --------------------- With the latest compilers (Delphi XE1+ and FPC 2.6.0+) the type NativeInt is available which has the native size of the OS (32-Bit or 64-Bit). Thus, it can be used to perform pointer arithmetrics. NOTE: Please do not use simple Cardinal() or Integer() casts on pointers only *) {$IFDEF COMPILERXE1_UP} {$DEFINE HAS_NATIVEINT} {$ENDIF} {$IFDEF FPC} {$DEFINE HAS_NATIVEINT} {$ENDIF} (* Miscellaneous Defines: ---------------------- *) {$IFDEF COMPILER6} {$DEFINE EXT_PROP_EDIT} {$ENDIF} {$IFNDEF COMPILER2010_UP} {$DEFINE USETHREADRESUME} {$ENDIF} {$IFDEF COMPILERFPC} {$UNDEF USETHREADRESUME} {$ENDIF} {$IFDEF LINUX} {$IFNDEF FPC} {$DEFINE BITS_GETTER} {$ENDIF} {$DEFINE UNIX} {$ENDIF} {$IFNDEF FPC} {$IFNDEF LINUX} {$DEFINE Windows} {$ENDIF} {$ENDIF} {$R-}{$Q-} // switch off overflow and range checking {$IFDEF COMPILER6_UP} {$DEFINE EXT_PROP_EDIT} {$ENDIF} {$IFDEF COMPILER2010_UP} {$DEFINE SUPPORT_ENHANCED_RECORDS} {$ENDIF} {$IFNDEF COMPILERFPC} {$DEFINE SUPPORT_XPTHEMES} // enable support for windows xp themes {$ENDIF} (* Compatibility Symbols --------------------- These symbols are deprecated and will be removed in future releases. *) {$IFDEF COMPILER6_UP} {$DEFINE COMPILER6} {$ENDIF} {$IFDEF COMPILER7_UP} {$DEFINE COMPILER7} {$ENDIF} {$IFDEF COMPILER2005_UP} {$DEFINE COMPILER2005} {$ENDIF} {$IFDEF COMPILER2006} {$DEFINE COMPILER2006} {$ENDIF} {$IFDEF COMPILER2007_UP} {$DEFINE COMPILER2007} {$ENDIF} {$IFDEF COMPILER2009_UP} {$DEFINE COMPILER2009} {$ENDIF} {$IFDEF COMPILER2010_UP} {$DEFINE COMPILER2010} {$ENDIF} {$IFDEF COMPILERXE1_UP} {$DEFINE COMPILERXE1} {$ENDIF} {$IFDEF COMPILERXE2_UP} {$DEFINE COMPILERXE2} {$ENDIF} {$IFDEF COMPILERXE3_UP} {$DEFINE COMPILERXE3} {$ENDIF} {$IFDEF COMPILERXE4_UP} {$DEFINE COMPILERXE4} {$ENDIF} {$IFDEF COMPILERXE5_UP} {$DEFINE COMPILERXE5} {$ENDIF} {$IFDEF COMPILERXE6_UP} {$DEFINE COMPILERXE6} {$ENDIF} {$IFDEF COMPILERXE7_UP} {$DEFINE COMPILERXE7} {$ENDIF} {$IFDEF COMPILERXE8_UP} {$DEFINE COMPILERXE8} {$ENDIF} {$IFDEF COMPILERRX_UP} {$DEFINE COMPILERRX8} {$ENDIF} {$IFDEF COMPILERRX1_UP} {$DEFINE COMPILERRX1} {$ENDIF} {$IFDEF COMPILERRX2_UP} {$DEFINE COMPILERRX2} {$ENDIF} |
Added src/graphics32/GR32_Containers.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 | unit GR32_Containers; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Repaint Optimizer Extension for Graphics32 * * The Initial Developer of the Original Code is * Andre Beckedorf - metaException * Andre@metaException.de * * Portions created by the Initial Developer are Copyright (C) 2005-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} {$IFDEF Windows} Windows, {$ELSE} Types, {$ENDIF} {$ELSE} Types, Windows, {$ENDIF} RTLConsts, GR32, SysUtils, Classes, TypInfo; const BUCKET_MASK = $FF; BUCKET_COUNT = BUCKET_MASK + 1; // 256 buckets by default type PPItem = ^PItem; PItem = Pointer; PPData = ^PData; PData = Pointer; PPointerBucketItem = ^TPointerBucketItem; TPointerBucketItem = record Item: PItem; Data: PData; end; TPointerBucketItemArray = array of TPointerBucketItem; TPointerBucket = record Count: Integer; Items: TPointerBucketItemArray; end; TPointerBucketArray = array[0..BUCKET_MASK] of TPointerBucket; { TPointerMap } { Associative pointer map Inspired by TBucketList, which is not available on D5/CB5, it is reimplemented from scratch, simple, optimized and light-weight. Not thread-safe. Does use exceptions only for Data property. } TPointerMap = class private FBuckets: TPointerBucketArray; FCount: Integer; protected function GetData(Item: PItem): PData; procedure SetData(Item: PItem; const Data: PData); function Exists(Item: Pointer; out BucketIndex, ItemIndex: Integer): Boolean; function Delete(BucketIndex, ItemIndex: Integer): PData; virtual; public destructor Destroy; override; function Add(NewItem: PItem): PPData; overload; function Add(NewItem: PItem; out IsNew: Boolean): PPData; overload; function Add(NewItem: PItem; NewData: PData): PPData; overload; function Add(NewItem: PItem; NewData: PData; out IsNew: Boolean): PPData; overload; function Remove(Item: PItem): PData; procedure Clear; function Contains(Item: PItem): Boolean; function Find(Item: PItem; out Data: PPData): Boolean; property Data[Item: PItem]: PData read GetData write SetData; default; property Count: Integer read FCount; end; { TPointerMapIterator } { Iterator object for the associative pointer map See below for usage example... } TPointerMapIterator = class private FSrcPointerMap: TPointerMap; FItem: PItem; FData: PData; FCurBucketIndex: Integer; FCurItemIndex: Integer; public constructor Create(SrcPointerMap: TPointerMap); function Next: Boolean; property Item: PItem read FItem; property Data: PData read FData; end; { USAGE EXAMPLE: -------------- with TPointerMapIterator.Create(MyPointerMap) do try while Next do begin // do something with Item and Data here... end; finally Free; end; } PPolyRects = ^TPolyRects; TPolyRects = Array[0..Maxint div 32 - 1] of TRect; { TRectList } { List that holds Rects Do not reuse TList due to pointer structure. A direct structure is more memory efficient. stripped version of TList blatantly stolen from Classes.pas } TRectList = class private FList: PPolyRects; FCount: Integer; FCapacity: Integer; protected function Get(Index: Integer): PRect; procedure Grow; virtual; procedure SetCapacity(NewCapacity: Integer); procedure SetCount(NewCount: Integer); public destructor Destroy; override; function Add(const Rect: TRect): Integer; procedure Clear; virtual; procedure Delete(Index: Integer); procedure Exchange(Index1, Index2: Integer); function IndexOf(const Rect: TRect): Integer; procedure Insert(Index: Integer; const Rect: TRect); procedure Move(CurIndex, NewIndex: Integer); function Remove(const Rect: TRect): Integer; procedure Pack; property Capacity: Integer read FCapacity write SetCapacity; property Count: Integer read FCount write SetCount; property Items[Index: Integer]: PRect read Get; default; property List: PPolyRects read FList; end; { TClassList } { This is a class that maintains a list of classes. } TClassList = class(TList) protected function GetItems(Index: Integer): TClass; procedure SetItems(Index: Integer; AClass: TClass); public function Add(AClass: TClass): Integer; function Extract(Item: TClass): TClass; function Remove(AClass: TClass): Integer; function IndexOf(AClass: TClass): Integer; function First: TClass; function Last: TClass; function Find(const AClassName: string): TClass; procedure GetClassNames(Strings: TStrings); procedure Insert(Index: Integer; AClass: TClass); property Items[Index: Integer]: TClass read GetItems write SetItems; default; end; PLinkedNode = ^TLinkedNode; TLinkedNode = record Prev: PLinkedNode; Next: PLinkedNode; Data: Pointer; end; TIteratorProc = procedure(Node: PLinkedNode; Index: Integer); TFreeDataEvent = procedure(Data: Pointer) of object; { TLinkedList } { A class for maintaining a linked list } TLinkedList = class private FCount: Integer; FHead: PLinkedNode; FTail: PLinkedNode; FOnFreeData: TFreeDataEvent; protected procedure DoFreeData(Data: Pointer); virtual; public destructor Destroy; override; function Add: PLinkedNode; procedure Remove(Node: PLinkedNode); function IndexOf(Node: PLinkedNode): Integer; function GetNode(Index: Integer): PLinkedNode; procedure Exchange(Node1, Node2: PLinkedNode); procedure InsertBefore(Node, NewNode: PLinkedNode); procedure InsertAfter(Node, NewNode: PLinkedNode); procedure Clear; procedure IterateList(CallBack: TIteratorProc); property Head: PLinkedNode read FHead write FHead; property Tail: PLinkedNode read FTail write FTail; property Count: Integer read FCount write FCount; property OnFreeData: TFreeDataEvent read FOnFreeData write FOnFreeData; end; procedure SmartAssign(Src, Dst: TPersistent; TypeKinds: TTypeKinds = tkProperties); procedure Advance(var Node: PLinkedNode; Steps: Integer = 1); implementation uses GR32_LowLevel; procedure SmartAssign(Src, Dst: TPersistent; TypeKinds: TTypeKinds = tkProperties); var Count, I: Integer; Props: PPropList; SubSrc, SubDst: TPersistent; begin Count := GetTypeData(Src.ClassInfo).PropCount; if Count = 0 then Exit; GetMem(Props, Count * SizeOf(PPropInfo)); try // Get the property list in an unsorted fashion. // This is important so the order in which the properties are defined is obeyed, // ie. mimic how the Delphi form loader would set the properties. Count := GetPropList(Src.ClassInfo, TypeKinds, Props, False); for I := 0 to Count - 1 do with Props^[I]^ do begin if PropType^.Kind = tkClass then begin // TODO DVT Added cast to fix ShortString to String warnings. Need to verify is OK SubDst := TPersistent(GetObjectProp(Dst, string(Name))); if not Assigned(SubDst) then Continue; SubSrc := TPersistent(GetObjectProp(Src, string(Name))); if Assigned(SubSrc) then SubDst.Assign(SubSrc); end else SetPropValue(Dst, string(Name), GetPropValue(Src, string(Name), True)); end; finally FreeMem(Props, Count * SizeOf(PPropInfo)); end; end; procedure Advance(var Node: PLinkedNode; Steps: Integer); begin if Steps > 0 then begin while Assigned(Node) and (Steps > 0) do begin Dec(Steps); Node := Node.Next; end; end else begin while Assigned(Node) and (Steps < 0) do begin Inc(Steps); Node := Node.Prev; end; end; end; { TPointerMap } function TPointerMap.Add(NewItem: PItem; NewData: PData): PPData; var Dummy: Boolean; begin Result := Add(NewItem, NewData, Dummy); end; function TPointerMap.Add(NewItem: PItem): PPData; var Dummy: Boolean; begin Result := Add(NewItem, nil, Dummy); end; function TPointerMap.Add(NewItem: PItem; out IsNew: Boolean): PPData; begin Result := Add(NewItem, nil, IsNew); end; function TPointerMap.Add(NewItem: PItem; NewData: PData; out IsNew: Boolean): PPData; var BucketIndex, ItemIndex, Capacity: Integer; begin if Exists(NewItem, BucketIndex, ItemIndex) then begin IsNew := False; Result := @FBuckets[BucketIndex].Items[ItemIndex].Data end else begin with FBuckets[BucketIndex] do begin Capacity := Length(Items); // enlarge capacity if completely used if Count = Capacity then begin if Capacity > 64 then Inc(Capacity, Capacity div 4) else if Capacity > 8 then Inc(Capacity, 16) else Inc(Capacity, 4); SetLength(Items, Capacity); end; with Items[Count] do begin Item := NewItem; Data := NewData; Result := @Data; end; Inc(Count); IsNew := True; end; Inc(FCount); end; end; procedure TPointerMap.Clear; var BucketIndex, ItemIndex: Integer; begin FCount := 0; for BucketIndex := 0 to BUCKET_MASK do with FBuckets[BucketIndex] do begin for ItemIndex := Count - 1 downto 0 do Delete(BucketIndex, ItemIndex); Count := 0; SetLength(Items, 0); end; end; destructor TPointerMap.Destroy; begin Clear; inherited Destroy; end; function TPointerMap.Delete(BucketIndex, ItemIndex: Integer): PData; begin with FBuckets[BucketIndex] do begin Result := Items[ItemIndex].Data; if FCount = 0 then Exit; Dec(Count); if Count = 0 then SetLength(Items, 0) else if (ItemIndex < Count) then Move(Items[ItemIndex + 1], Items[ItemIndex], (Count - ItemIndex) * SizeOf(TPointerBucketItem)); end; Dec(FCount); end; function TPointerMap.Remove(Item: PItem): PData; var BucketIndex, ItemIndex: Integer; begin if Exists(Item, BucketIndex, ItemIndex) then Result := Delete(BucketIndex, ItemIndex) else Result := nil; end; function TPointerMap.Contains(Item: PItem): Boolean; var Dummy: Integer; begin Result := Exists(Item, Dummy, Dummy); end; function TPointerMap.Find(Item: PItem; out Data: PPData): Boolean; var BucketIndex, ItemIndex: Integer; begin Result := Exists(Item, BucketIndex, ItemIndex); if Result then Data := @FBuckets[BucketIndex].Items[ItemIndex].Data; end; function TPointerMap.Exists(Item: PItem; out BucketIndex, ItemIndex: Integer): Boolean; var I: Integer; begin {$IFDEF HAS_NATIVEINT} BucketIndex := NativeUInt(Item) shr 8 and BUCKET_MASK; // KISS pointer hash(TM) {$ELSE} BucketIndex := Cardinal(Item) shr 8 and BUCKET_MASK; // KISS pointer hash(TM) {$ENDIF} // due to their randomness, pointers most commonly differ at byte 1, we use // this characteristic for our hash and just apply the mask to it. // Worst case scenario happens when most changes are at byte 0, which causes // one bucket to be saturated whereas the other buckets are almost empty... Result := False; with FBuckets[BucketIndex] do for I := 0 to Count - 1 do if Items[I].Item = Item then begin ItemIndex := I; Result := True; Exit; end; end; function TPointerMap.GetData(Item: PItem): PData; var BucketIndex, ItemIndex: Integer; begin if not Exists(Item, BucketIndex, ItemIndex) then {$IFDEF FPC} raise EListError.CreateFmt(SItemNotFound, [Item]) {$ELSE} {$IFDEF HAS_NATIVEINT} raise EListError.CreateFmt(SItemNotFound, [NativeInt(Item)]) {$ELSE} raise EListError.CreateFmt(SItemNotFound, [Integer(Item)]) {$ENDIF} {$ENDIF} else Result := FBuckets[BucketIndex].Items[ItemIndex].Data; end; procedure TPointerMap.SetData(Item: PItem; const Data: PData); var BucketIndex, ItemIndex: Integer; begin if not Exists(Item, BucketIndex, ItemIndex) then {$IFDEF FPC} raise EListError.CreateFmt(SItemNotFound, [Item]) {$ELSE} {$IFDEF HAS_NATIVEINT} raise EListError.CreateFmt(SItemNotFound, [NativeInt(Item)]) {$ELSE} raise EListError.CreateFmt(SItemNotFound, [Integer(Item)]) {$ENDIF} {$ENDIF} else FBuckets[BucketIndex].Items[ItemIndex].Data := Data; end; { TPointerMapIterator } constructor TPointerMapIterator.Create(SrcPointerMap: TPointerMap); begin inherited Create; FSrcPointerMap := SrcPointerMap; FCurBucketIndex := -1; FCurItemIndex := -1; end; function TPointerMapIterator.Next: Boolean; begin if FCurItemIndex > 0 then Dec(FCurItemIndex) else begin FCurItemIndex := -1; while (FCurBucketIndex < BUCKET_MASK) and (FCurItemIndex = -1) do begin Inc(FCurBucketIndex); FCurItemIndex := FSrcPointerMap.FBuckets[FCurBucketIndex].Count - 1; end; if FCurBucketIndex = BUCKET_MASK then begin Result := False; Exit; end end; Result := True; with FSrcPointerMap.FBuckets[FCurBucketIndex].Items[FCurItemIndex] do begin FItem := Item; FData := Data; end; end; { TRectList } destructor TRectList.Destroy; begin SetCount(0); SetCapacity(0); end; function TRectList.Add(const Rect: TRect): Integer; begin Result := FCount; if Result = FCapacity then Grow; FList^[Result] := Rect; Inc(FCount); end; procedure TRectList.Clear; begin SetCount(0); SetCapacity(10); end; procedure TRectList.Delete(Index: Integer); begin Dec(FCount); if Index < FCount then System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(TRect)); end; procedure TRectList.Exchange(Index1, Index2: Integer); var Item: TRect; begin Item := FList^[Index1]; FList^[Index1] := FList^[Index2]; FList^[Index2] := Item; end; function TRectList.Get(Index: Integer): PRect; begin if (Index < 0) or (Index >= FCount) then Result := nil else Result := @FList^[Index]; end; procedure TRectList.Grow; var Delta: Integer; begin if FCapacity > 128 then Delta := FCapacity div 4 else if FCapacity > 8 then Delta := 32 else Delta := 8; SetCapacity(FCapacity + Delta); end; function TRectList.IndexOf(const Rect: TRect): Integer; begin Result := 0; while (Result < FCount) and not EqualRect(FList^[Result], Rect) do Inc(Result); if Result = FCount then Result := -1; end; procedure TRectList.Insert(Index: Integer; const Rect: TRect); begin if FCount = FCapacity then Grow; if Index < FCount then System.Move(FList^[Index], FList^[Index + 1], (FCount - Index) * SizeOf(TRect)); FList^[Index] := Rect; Inc(FCount); end; procedure TRectList.Move(CurIndex, NewIndex: Integer); var Item: TRect; begin if CurIndex <> NewIndex then begin Item := Get(CurIndex)^; Delete(CurIndex); Insert(NewIndex, Item); end; end; function TRectList.Remove(const Rect: TRect): Integer; begin Result := IndexOf(Rect); if Result >= 0 then Delete(Result); end; procedure TRectList.Pack; var I: Integer; begin for I := FCount - 1 downto 0 do if Items[I] = nil then Delete(I); end; procedure TRectList.SetCapacity(NewCapacity: Integer); begin if NewCapacity <> FCapacity then begin ReallocMem(FList, NewCapacity * SizeOf(TRect)); FCapacity := NewCapacity; end; end; procedure TRectList.SetCount(NewCount: Integer); var I: Integer; begin if NewCount > FCapacity then SetCapacity(NewCount); if NewCount > FCount then FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(TRect), 0) else for I := FCount - 1 downto NewCount do Delete(I); FCount := NewCount; end; { TClassList } function TClassList.Add(AClass: TClass): Integer; begin Result := inherited Add(AClass); end; function TClassList.Extract(Item: TClass): TClass; begin Result := TClass(inherited Extract(Item)); end; function TClassList.Find(const AClassName: string): TClass; var I: Integer; begin Result := nil; for I := 0 to Count - 1 do if TClass(List[I]).ClassName = AClassName then begin Result := TClass(List[I]); Break; end; end; function TClassList.First: TClass; begin Result := TClass(inherited First); end; procedure TClassList.GetClassNames(Strings: TStrings); var I: Integer; begin for I := 0 to Count - 1 do Strings.Add(TClass(List[I]).ClassName); end; function TClassList.GetItems(Index: Integer): TClass; begin Result := TClass(inherited Items[Index]); end; function TClassList.IndexOf(AClass: TClass): Integer; begin Result := inherited IndexOf(AClass); end; procedure TClassList.Insert(Index: Integer; AClass: TClass); begin inherited Insert(Index, AClass); end; function TClassList.Last: TClass; begin Result := TClass(inherited Last); end; function TClassList.Remove(AClass: TClass): Integer; begin Result := inherited Remove(AClass); end; procedure TClassList.SetItems(Index: Integer; AClass: TClass); begin inherited Items[Index] := AClass; end; { TLinkedList } function TLinkedList.Add: PLinkedNode; begin New(Result); Result.Data := nil; Result.Next := nil; Result.Prev := nil; if Head = nil then begin Head := Result; Tail := Result; end else InsertAfter(FTail, Result); end; procedure TLinkedList.Clear; var P, NextP: PLinkedNode; begin P := Head; while Assigned(P) do begin NextP := P.Next; DoFreeData(P.Data); Dispose(P); P := NextP; end; Head := nil; Tail := nil; Count := 0; end; destructor TLinkedList.Destroy; begin Clear; end; procedure TLinkedList.DoFreeData(Data: Pointer); begin if Assigned(FOnFreeData) then FOnFreeData(Data); end; procedure TLinkedList.Exchange(Node1, Node2: PLinkedNode); begin if Assigned(Node1) and Assigned(Node2) and (Node1 <> Node2) then begin if Assigned(Node1.Prev) then Node1.Prev.Next := Node2; if Assigned(Node1.Next) then Node1.Next.Prev := Node2; if Assigned(Node2.Prev) then Node2.Prev.Next := Node1; if Assigned(Node2.Next) then Node2.Next.Prev := Node1; if Head = Node1 then Head := Node2 else if Head = Node2 then Head := Node1; if Tail = Node1 then Tail := Node2 else if Tail = Node2 then Tail := Node1; Swap(Pointer(Node1.Next), Pointer(Node2.Next)); Swap(Pointer(Node1.Prev), Pointer(Node2.Prev)); end; end; function TLinkedList.GetNode(Index: Integer): PLinkedNode; begin Result := Head; Advance(Result, Index); end; function TLinkedList.IndexOf(Node: PLinkedNode): Integer; var I: Integer; P: PLinkedNode; begin Result := -1; P := Head; for I := 0 to Count - 1 do begin if P = Node then begin Result := I; Exit; end; P := P.Next; end; end; procedure TLinkedList.InsertAfter(Node, NewNode: PLinkedNode); begin if Assigned(Node) and Assigned(NewNode) then begin NewNode.Prev := Node; NewNode.Next := Node.Next; if Assigned(Node.Next) then Node.Next.Prev := NewNode; Node.Next := NewNode; if Node = Tail then Tail := NewNode; Inc(FCount); end; end; procedure TLinkedList.InsertBefore(Node, NewNode: PLinkedNode); begin if Assigned(Node) and Assigned(NewNode) then begin NewNode.Next := Node; NewNode.Prev := Node.Prev; if Assigned(Node.Prev) then Node.Prev.Next := NewNode; Node.Prev := NewNode; if Node = Head then Head := NewNode; Inc(FCount); end; end; procedure TLinkedList.IterateList(CallBack: TIteratorProc); var I: Integer; P: PLinkedNode; begin P := Head; for I := 0 to Count - 1 do begin CallBack(P, I); P := P.Next; end; end; procedure TLinkedList.Remove(Node: PLinkedNode); begin if Assigned(Node) then begin DoFreeData(Node.Data); if Assigned(Node.Prev) then Node.Prev.Next := Node.Next; if Assigned(Node.Next) then Node.Next.Prev := Node.Prev; if Node = Head then Head := Node.Next; if Node = Tail then Tail := Node.Prev; Dispose(Node); Dec(FCount); end; end; end. |
Added src/graphics32/GR32_Dsgn_Bitmap.dfm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | object PictureEditorForm: TPictureEditorForm Left = 247 Top = 357 BorderIcons = [biSystemMenu] BorderStyle = bsSizeToolWin Caption = 'Bitmap32 Editor' ClientHeight = 411 ClientWidth = 338 Color = clBtnFace Constraints.MinHeight = 200 Constraints.MinWidth = 310 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'Tahoma' Font.Style = [] OldCreateOrder = False Position = poScreenCenter PixelsPerInch = 96 TextHeight = 13 object Bevel1: TBevel Left = 0 Top = 54 Width = 338 Height = 6 Align = alTop Shape = bsTopLine Style = bsRaised end object ToolBar: TToolBar Left = 0 Top = 0 Width = 338 Height = 44 AutoSize = True BorderWidth = 1 ButtonHeight = 36 ButtonWidth = 54 Caption = 'ToolBar' EdgeBorders = [ebTop, ebBottom] Images = ImageList ShowCaptions = True TabOrder = 0 object Load: TToolButton Left = 0 Top = 0 Caption = ' Load ' ImageIndex = 0 OnClick = LoadClick end object Save: TToolButton Left = 54 Top = 0 Caption = 'Save' ImageIndex = 1 OnClick = SaveClick end object Clear: TToolButton Left = 108 Top = 0 Caption = 'Clear' ImageIndex = 2 OnClick = ClearClick end object ToolButton2: TToolButton Left = 162 Top = 0 Width = 8 Caption = 'ToolButton2' ImageIndex = 3 Style = tbsSeparator end object Copy: TToolButton Left = 170 Top = 0 Caption = 'Copy' ImageIndex = 3 OnClick = CopyClick end object Paste: TToolButton Left = 224 Top = 0 Caption = 'Paste' ImageIndex = 4 OnClick = PasteClick end end object PageControl: TPageControl Left = 0 Top = 60 Width = 338 Height = 318 ActivePage = ImageSheet Align = alClient HotTrack = True MultiLine = True TabOrder = 1 TabPosition = tpBottom object ImageSheet: TTabSheet BorderWidth = 2 Caption = 'RGB Image' end object AlphaSheet: TTabSheet BorderWidth = 2 Caption = 'Alpha Channel' ImageIndex = 1 end end object Panel1: TPanel Left = 0 Top = 378 Width = 338 Height = 33 Align = alBottom BevelOuter = bvNone TabOrder = 2 DesignSize = ( 338 33) object Label1: TLabel Left = 8 Top = 8 Width = 30 Height = 13 Anchors = [akLeft, akBottom] Caption = 'Magn:' end object OKButton: TButton Left = 186 Top = 6 Width = 64 Height = 23 Anchors = [akRight, akBottom] Caption = 'OK' Default = True ModalResult = 1 TabOrder = 0 end object Cancel: TButton Left = 261 Top = 6 Width = 65 Height = 23 Anchors = [akRight, akBottom] Cancel = True Caption = 'Cancel' ModalResult = 2 TabOrder = 1 end object MagnCombo: TComboBox Left = 48 Top = 7 Width = 73 Height = 21 Style = csDropDownList Anchors = [akLeft, akBottom] TabOrder = 2 OnChange = MagnComboChange Items.Strings = ( ' 25 %' ' 50 %' '100 %' '200 %' '400 %' '800 %' 'To Fit') end end object Panel2: TPanel Left = 0 Top = 44 Width = 338 Height = 10 Align = alTop Alignment = taLeftJustify BevelOuter = bvNone Color = clInfoBk Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -9 Font.Name = 'Small Fonts' Font.Style = [] ParentFont = False TabOrder = 3 end object ImageList: TImageList Left = 184 Top = 82 Bitmap = { 494C010106002400240010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 0000000000003600000028000000400000002000000001002000000000000020 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000007B0000007B0000007B0000007B0000007B0000007B00 00007B0000007B0000007B0000007B0000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000007B000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF00FFFFFF007B000000000000000000000084848400FFFF FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000000000007B7B7B00007B7B007B7B 7B00007B7B007B7B7B007B000000FFFFFF007B0000007B0000007B0000007B00 00007B0000007B000000FFFFFF007B0000000000000000000000000000008484 8400FFFFFF008484840084848400000000000000000084848400FFFFFF00FFFF FF00FFFFFF00FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000000000000000000000000000000000007B7B007B7B7B00007B 7B007B7B7B00007B7B007B000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF00FFFFFF007B0000000000000000000000000000000000 000084848400000000000000000000000000000000000000000000000000FFFF FF00FFFFFF00FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000000000007B7B7B00007B7B007B7B 7B00007B7B007B7B7B007B000000FFFFFF007B0000007B0000007B000000FFFF FF007B0000007B0000007B0000007B0000000000000000000000000000000000 0000FFFFFF008484840000000000000000000000000000000000000000000000 0000FFFFFF00FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000000000000000000000000000000000007B7B007B7B7B00007B 7B007B7B7B00007B7B007B000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF007B000000FFFFFF007B00000000000000000000000000000000000000C6C6 C600FFFFFF00FFFFFF0084848400000000000000000000000000000000000000 000084848400FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000000000007B7B7B00007B7B007B7B 7B00007B7B007B7B7B007B000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF007B0000007B0000000000000000000000000000000000000000000000FFFF FF00FFFFFF00FFFFFF00FFFFFF00848484000000000000000000000000000000 000000000000FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000000000000000000000000000000000007B7B007B7B7B00007B 7B007B7B7B00007B7B007B0000007B0000007B0000007B0000007B0000007B00 00007B000000000000000000000000000000000000000000000000000000FFFF FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF008484840000000000000000000000 000000000000FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000000000007B7B7B00007B7B007B7B 7B00007B7B007B7B7B00007B7B007B7B7B00007B7B007B7B7B00007B7B007B7B 7B00007B7B00000000000000000000000000000000000000000000000000C6C6 C600FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0084848400000000000000 000084848400FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000000000000000000000000000000000007B7B007B7B7B000000 0000000000000000000000000000000000000000000000000000000000007B7B 7B007B7B7B000000000000000000000000000000000000000000000000000000 0000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00848484000000 000084848400FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000000000007B7B7B007B7B7B000000 0000BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00000000007B7B 7B00007B7B000000000000000000000000000000000000000000000000000000 000000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF008484 8400FFFFFF00FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000000000000000000000000000000000007B7B007B7B7B00007B 7B000000000000FFFF00000000000000000000FFFF00000000007B7B7B00007B 7B007B7B7B000000000000000000000000000000000000000000000000000000 00000000000000000000C6C6C600FFFFFF00FFFFFF00C6C6C600000000000000 000084848400FFFFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000FFFF0000FFFF000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000008484840000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000007B7B00007B 7B00000000000000000000000000000000000000000000000000BDBDBD00BDBD BD0000000000007B7B0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000007B00FFFFFF00000000000000000000000000000000000000 000000000000000000007B0000007B0000007B0000007B0000007B0000007B00 00007B0000007B0000007B000000000000000000000000000000007B7B00007B 7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B7B000000 0000000000000000000000000000000000000000000000000000007B7B00007B 7B00000000000000000000000000000000000000000000000000BDBDBD00BDBD BD0000000000007B7B0000000000000000000000000000000000000000000000 7B00FFFFFF000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000007B000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF007B000000000000000000000000FFFF0000000000007B 7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B 7B00000000000000000000000000000000000000000000000000007B7B00007B 7B00000000000000000000000000000000000000000000000000BDBDBD00BDBD BD0000000000007B7B000000000000000000000000000000000000007B000000 7B0000007B00FFFFFF0000000000000000000000000000000000000000000000 000000007B00FFFFFF0000000000000000000000000000000000000000000000 000000000000000000007B000000FFFFFF000000000000000000000000000000 000000000000FFFFFF007B0000000000000000000000FFFFFF0000FFFF000000 0000007B7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B 7B00007B7B000000000000000000000000000000000000000000007B7B00007B 7B00000000000000000000000000000000000000000000000000000000000000 000000000000007B7B000000000000000000000000000000000000007B000000 7B0000007B00FFFFFF0000000000000000000000000000000000000000000000 7B00FFFFFF000000000000000000000000000000000000000000000000000000 000000000000000000007B000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF007B000000000000000000000000FFFF00FFFFFF0000FF FF0000000000007B7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B 7B00007B7B00007B7B0000000000000000000000000000000000007B7B00007B 7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B7B00007B 7B00007B7B00007B7B0000000000000000000000000000000000000000000000 7B0000007B0000007B00FFFFFF0000000000000000000000000000007B000000 7B00FFFFFF0000000000000000000000000000000000FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF007B000000FFFFFF000000000000000000000000000000 000000000000FFFFFF007B0000000000000000000000FFFFFF0000FFFF00FFFF FF0000FFFF000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000007B7B00007B 7B00000000000000000000000000000000000000000000000000000000000000 0000007B7B00007B7B0000000000000000000000000000000000000000000000 000000007B0000007B0000007B00FFFFFF000000000000007B0000007B00FFFF FF000000000000000000000000000000000000000000FFFFFF00000000000000 000000000000000000007B000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF007B000000000000000000000000FFFF00FFFFFF0000FF FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00000000000000 0000000000000000000000000000000000000000000000000000007B7B000000 0000BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBD BD0000000000007B7B0000000000000000000000000000000000000000000000 00000000000000007B0000007B0000007B0000007B0000007B00FFFFFF000000 00000000000000000000000000000000000000000000FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF007B000000FFFFFF000000000000000000FFFFFF007B00 00007B0000007B0000007B0000000000000000000000FFFFFF0000FFFF00FFFF FF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF00000000000000 0000000000000000000000000000000000000000000000000000007B7B000000 0000BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBD BD0000000000007B7B0000000000000000000000000000000000000000000000 0000000000000000000000007B0000007B0000007B00FFFFFF00000000000000 00000000000000000000000000000000000000000000FFFFFF00000000000000 000000000000000000007B000000FFFFFF00FFFFFF00FFFFFF00FFFFFF007B00 0000FFFFFF007B00000000000000000000000000000000FFFF00FFFFFF0000FF FF00000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000007B7B000000 0000BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBD BD0000000000007B7B0000000000000000000000000000000000000000000000 00000000000000007B0000007B0000007B0000007B0000007B00FFFFFF000000 00000000000000000000000000000000000000000000FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF007B000000FFFFFF00FFFFFF00FFFFFF00FFFFFF007B00 00007B0000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000007B7B000000 0000BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBD BD0000000000007B7B0000000000000000000000000000000000000000000000 000000007B0000007B0000007B00FFFFFF000000000000007B00FFFFFF000000 00000000000000000000000000000000000000000000FFFFFF00000000000000 0000FFFFFF00000000007B0000007B0000007B0000007B0000007B0000007B00 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000007B7B000000 0000BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBD BD0000000000000000000000000000000000000000000000000000007B000000 7B0000007B0000007B00FFFFFF0000000000000000000000000000007B000000 7B00FFFFFF0000000000000000000000000000000000FFFFFF00FFFFFF00FFFF FF00FFFFFF0000000000FFFFFF00000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000007B7B000000 0000BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBDBD00BDBD BD0000000000BDBDBD0000000000000000000000000000007B0000007B000000 7B0000007B00FFFFFF0000000000000000000000000000000000000000000000 7B0000007B00FFFFFF00000000000000000000000000FFFFFF00FFFFFF00FFFF FF00FFFFFF000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000007B0000007B00FFFF FF00000000000000000000000000000000000000000000000000000000000000 000000007B0000007B00FFFFFF00000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000424D3E000000000000003E000000 2800000040000000200000000100010000000000000100000000000000000000 000000000000000000000000FFFFFF00FFFFFFFF00000000FC00800100000000 8000800100000000000080010000000000008001000000000000800100000000 0001800100000000000380010000000000038001000000000003800100000000 0003800100000000000380010000000000038001000000008007800100000000 F87F800100000000FFFFFFFF00000000FFFFFFFFFFFFFFFFFFFFC001FFFFFFFF 001F8001FFF9FC01000F8001E7FFFC0100078001C3F3FC0100038001C3E70001 00018001E1C7000100008001F08F0001001F8001F81F0001001F8001FC3F0003 001F8001F81F00078FF18001F09F000FFFF98001C1C700FFFF75800183E301FF FF8F80018FF103FFFFFFFFFFFFFFFFFF00000000000000000000000000000000 000000000000} end object Timer: TTimer Interval = 200 OnTimer = TimerTimer Left = 122 Top = 84 end object PopupMenu: TPopupMenu Images = ImageList OnPopup = PopupMenuPopup Left = 242 Top = 84 object mnLoad: TMenuItem Caption = 'Load...' ImageIndex = 0 OnClick = LoadClick end object mnSave: TMenuItem Caption = 'Save...' ImageIndex = 1 OnClick = SaveClick end object mnClear: TMenuItem Caption = 'Clear' ImageIndex = 2 OnClick = ClearClick end object mnSeparator: TMenuItem Caption = '-' end object mnCopy: TMenuItem Caption = 'Copy' ImageIndex = 3 OnClick = CopyClick end object mnPaste: TMenuItem Caption = 'Paste' ImageIndex = 4 OnClick = PasteClick end object mnSeparator2: TMenuItem Caption = '-' end object mnInvert: TMenuItem Caption = 'Invert' ImageIndex = 5 OnClick = mnInvertClick end end end |
Added src/graphics32/GR32_Dsgn_Bitmap.lfm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 | object PictureEditorForm: TPictureEditorForm Left = 247 Height = 440 Top = 357 Width = 346 HorzScrollBar.Page = 345 VertScrollBar.Page = 439 ActiveControl = OKButton BorderIcons = [biSystemMenu] BorderStyle = bsSizeToolWin Caption = 'Bitmap32 Editor' ClientHeight = 440 ClientWidth = 346 Constraints.MinHeight = 200 Constraints.MinWidth = 310 Font.Height = -11 Font.Name = 'Tahoma' Position = poScreenCenter LCLVersion = '0.9.31' object Bevel1: TBevel Left = 0 Height = 6 Top = 51 Width = 346 Align = alTop Shape = bsTopLine Style = bsRaised end object ToolBar: TToolBar Left = 0 Height = 40 Top = 0 Width = 346 AutoSize = True BorderWidth = 1 ButtonHeight = 36 ButtonWidth = 54 Caption = 'ToolBar' EdgeBorders = [ebTop, ebBottom] Images = ImageList ShowCaptions = True TabOrder = 0 object Load: TToolButton Left = 1 Top = 2 Caption = ' Load ' ImageIndex = 0 OnClick = LoadClick end object Save: TToolButton Left = 56 Top = 2 Caption = 'Save' ImageIndex = 1 OnClick = SaveClick end object Clear: TToolButton Left = 110 Top = 2 Caption = 'Clear' ImageIndex = 2 OnClick = ClearClick end object ToolButton2: TToolButton Left = 164 Top = 2 Width = 10 Caption = 'ToolButton2' ImageIndex = 3 Style = tbsSeparator end object Copy: TToolButton Left = 174 Top = 2 Caption = 'Copy' ImageIndex = 3 OnClick = CopyClick end object Paste: TToolButton Left = 228 Top = 2 Caption = 'Paste' ImageIndex = 4 OnClick = PasteClick end end object PageControl: TPageControl Left = 0 Height = 350 Top = 57 Width = 346 ActivePage = ImageSheet Align = alClient TabIndex = 0 TabOrder = 1 TabPosition = tpBottom object ImageSheet: TTabSheet Caption = 'RGB Image' end object AlphaSheet: TTabSheet Caption = 'Alpha Channel' ImageIndex = 1 end end object Panel1: TPanel Left = 0 Height = 33 Top = 407 Width = 346 Align = alBottom BevelOuter = bvNone ClientHeight = 33 ClientWidth = 346 TabOrder = 2 object Label1: TLabel Left = 8 Height = 14 Top = 8 Width = 31 Anchors = [akLeft, akBottom] Caption = 'Magn:' ParentColor = False end object OKButton: TButton Left = 194 Height = 23 Top = 6 Width = 64 Anchors = [akRight, akBottom] BorderSpacing.InnerBorder = 4 Caption = 'OK' Default = True ModalResult = 1 TabOrder = 0 end object Cancel: TButton Left = 269 Height = 23 Top = 6 Width = 65 Anchors = [akRight, akBottom] BorderSpacing.InnerBorder = 4 Cancel = True Caption = 'Cancel' ModalResult = 2 TabOrder = 1 end object MagnCombo: TComboBox Left = 48 Height = 21 Top = 7 Width = 73 Anchors = [akLeft, akBottom] ItemHeight = 13 Items.Strings = ( ' 25 %' ' 50 %' '100 %' '200 %' '400 %' '800 %' 'To Fit' ) OnChange = MagnComboChange Style = csDropDownList TabOrder = 2 end end object Panel2: TPanel Left = 0 Height = 11 Top = 40 Width = 346 Align = alTop Alignment = taLeftJustify BevelOuter = bvNone Color = clInfoBk Font.Height = -8 Font.Name = 'Small Fonts' ParentColor = False ParentFont = False TabOrder = 3 end object ImageList: TImageList left = 184 top = 82 Bitmap = { 4C69060000001000000010000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000000000FF000000FF000000FF0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000FF0000000000000000000000000000 00FF00000000000000FF00000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000FF000000FF0000000000000000000000FF000000FF000000FF0000 0000000000000000000000000000000000000000000000000000000000000000 00FF000000FF000000FF00000000000000FF00FFFFFFFFFFFFFF00FFFFFF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000000000 0000000000000000000000000000000000FFFFFFFFFF00FFFFFFFFFFFFFF00FF FFFFFFFFFFFF00FFFFFFFFFFFFFF00FFFFFFFFFFFFFF000000FF000000000000 0000000000000000000000000000000000FF00FFFFFFFFFFFFFF00FFFFFFFFFF FFFF00FFFFFFFFFFFFFF00FFFFFFFFFFFFFF00FFFFFF000000FF000000000000 0000000000000000000000000000000000FFFFFFFFFF00FFFFFFFFFFFFFF00FF FFFF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF00FFFFFFFFFFFFFF00FFFFFF0000 00FF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B 7BFF007B7BFF000000FF00000000000000FFFFFFFFFF00FFFFFF000000FF007B 7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B 7BFF000000FF0000000000000000000000FF00FFFFFF000000FF007B7BFF007B 7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF0000 00FF000000000000000000000000000000FF000000FF007B7BFF007B7BFF007B 7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF000000FF0000 0000000000000000000000000000000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF0000000000000000000000FF007B7BFF000000FFBDBD BDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFF0000 00FFBDBDBDFF000000FF0000000000000000000000FF007B7BFF000000FFBDBD BDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFF0000 00FF000000FF000000FF0000000000000000000000FF007B7BFF000000FFBDBD BDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFF0000 00FF007B7BFF000000FF0000000000000000000000FF007B7BFF000000FFBDBD BDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFF0000 00FF007B7BFF000000FF0000000000000000000000FF007B7BFF000000FFBDBD BDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFF0000 00FF007B7BFF000000FF0000000000000000000000FF007B7BFF000000FFBDBD BDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFF0000 00FF007B7BFF000000FF0000000000000000000000FF007B7BFF007B7BFF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF007B 7BFF007B7BFF000000FF0000000000000000000000FF007B7BFF007B7BFF007B 7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B 7BFF007B7BFF000000FF0000000000000000000000FF007B7BFF007B7BFF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF007B7BFF000000FF0000000000000000000000FF007B7BFF007B7BFF0000 00FF000000FF000000FF000000FF000000FF000000FFBDBDBDFFBDBDBDFF0000 00FF007B7BFF000000FF0000000000000000000000FF007B7BFF007B7BFF0000 00FF000000FF000000FF000000FF000000FF000000FFBDBDBDFFBDBDBDFF0000 00FF007B7BFF000000FF0000000000000000000000FF007B7BFF007B7BFF0000 00FF000000FF000000FF000000FF000000FF000000FFBDBDBDFFBDBDBDFF0000 00FF007B7BFF000000FF000000000000000000000000000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF00000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000000000000000000000000000007BFF00007BFFFFFFFFFF0000 0000000000000000000000000000000000000000000000000000000000000000 7BFF00007BFFFFFFFFFF000000000000000000007BFF00007BFF00007BFF0000 7BFFFFFFFFFF000000000000000000000000000000000000000000007BFF0000 7BFFFFFFFFFF0000000000000000000000000000000000007BFF00007BFF0000 7BFF00007BFFFFFFFFFF00000000000000000000000000007BFF00007BFFFFFF FFFF000000000000000000000000000000000000000000000000000000000000 7BFF00007BFF00007BFFFFFFFFFF0000000000007BFFFFFFFFFF000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000007BFF00007BFF00007BFF00007BFF00007BFFFFFFFFFF000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000007BFF00007BFF00007BFFFFFFFFFF00000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000007BFF00007BFF00007BFF00007BFF00007BFFFFFFFFFF000000000000 0000000000000000000000000000000000000000000000000000000000000000 7BFF00007BFF00007BFFFFFFFFFF0000000000007BFF00007BFFFFFFFFFF0000 000000000000000000000000000000000000000000000000000000007BFF0000 7BFF00007BFFFFFFFFFF00000000000000000000000000007BFF00007BFFFFFF FFFF000000000000000000000000000000000000000000007BFF00007BFF0000 7BFFFFFFFFFF000000000000000000000000000000000000000000007BFFFFFF FFFF000000000000000000000000000000000000000000007BFF00007BFF0000 7BFFFFFFFFFF0000000000000000000000000000000000000000000000000000 7BFFFFFFFFFF000000000000000000000000000000000000000000007BFFFFFF FFFF000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000007BFFFFFFFFFF00000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000FF000000FF000000FF000000FF0000 00FF000000FF0000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFF000000FF000000FF00000000000000000000000000000000000000000000 0000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFF000000FFFFFFFFFF000000FF000000000000000000000000000000000000 0000000000000000000000000000000000FFFFFFFFFF000000FF000000FFFFFF FFFF000000FF7B0000FF7B0000FF7B0000FF7B0000FF7B0000FF7B0000FF0000 0000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF7B0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B0000FF7B00 00FF000000000000000000000000000000FFFFFFFFFF000000FF000000FF0000 00FF000000FF7B0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B0000FFFFFF FFFF7B0000FF0000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF7B0000FFFFFFFFFF000000FF000000FFFFFFFFFF7B0000FF7B00 00FF7B0000FF7B0000FF00000000000000FFFFFFFFFF000000FF000000FF0000 00FF000000FF7B0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF7B0000FF00000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF7B0000FFFFFFFFFF000000FF000000FF000000FF000000FF0000 00FFFFFFFFFF7B0000FF00000000000000FF000000FF000000FF000000FF0000 00FF000000FF7B0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF7B0000FF00000000000000000000000000000000000000000000 0000000000007B0000FFFFFFFFFF000000FF000000FF000000FF000000FF0000 00FFFFFFFFFF7B0000FF00000000000000000000000000000000000000000000 0000000000007B0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF7B0000FF00000000000000000000000000000000000000000000 0000000000007B0000FF7B0000FF7B0000FF7B0000FF7B0000FF7B0000FF7B00 00FF7B0000FF7B0000FF00000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000FF000000FF000000FF000000FF0000000000000000000000000000 000000000000000000000000000000000000000000FF000000FF000000FF0000 00FF000000FF00FFFFFF00FFFFFF000000FF000000FF000000FF000000FF0000 00FF000000000000000000000000000000FF007B7BFF7B7B7BFF007B7BFF0000 00FF00FFFFFF000000FF000000FF00FFFFFF000000FF7B7B7BFF007B7BFF7B7B 7BFF000000FF0000000000000000000000FF7B7B7BFF7B7B7BFF000000FFBDBD BDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFF000000FF7B7B7BFF007B 7BFF000000FF0000000000000000000000FF007B7BFF7B7B7BFF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF7B7B7BFF7B7B 7BFF000000FF0000000000000000000000FF7B7B7BFF007B7BFF7B7B7BFF007B 7BFF7B7B7BFF007B7BFF7B7B7BFF007B7BFF7B7B7BFF007B7BFF7B7B7BFF007B 7BFF000000FF0000000000000000000000FF007B7BFF7B7B7BFF007B7BFF7B7B 7BFF007B7BFF7B0000FF7B0000FF7B0000FF7B0000FF7B0000FF7B0000FF7B00 00FF000000FF0000000000000000000000FF7B7B7BFF007B7BFF7B7B7BFF007B 7BFF7B7B7BFF7B0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B00 00FF7B0000FF0000000000000000000000FF007B7BFF7B7B7BFF007B7BFF7B7B 7BFF007B7BFF7B0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B00 00FFFFFFFFFF7B0000FF00000000000000FF7B7B7BFF007B7BFF7B7B7BFF007B 7BFF7B7B7BFF7B0000FFFFFFFFFF7B0000FF7B0000FF7B0000FFFFFFFFFF7B00 00FF7B0000FF7B0000FF7B0000FF000000FF007B7BFF7B7B7BFF007B7BFF7B7B 7BFF007B7BFF7B0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFF7B0000FF000000FF7B7B7BFF007B7BFF7B7B7BFF007B 7BFF7B7B7BFF7B0000FFFFFFFFFF7B0000FF7B0000FF7B0000FF7B0000FF7B00 00FF7B0000FFFFFFFFFF7B0000FF00000000000000FF000000FF000000FF0000 00FF000000FF7B0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFF7B0000FF000000000000000000000000000000000000 0000000000007B0000FF7B0000FF7B0000FF7B0000FF7B0000FF7B0000FF7B00 00FF7B0000FF7B0000FF7B0000FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF0000000000000000000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF848484FF000000FF0000000000000000000000FF000000FF000000FF0000 00FF000000FFC6C6C6FFFFFFFFFFFFFFFFFFC6C6C6FF000000FF000000FF8484 84FFFFFFFFFF000000FF0000000000000000000000FF000000FF000000FF0000 00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF848484FFFFFF FFFFFFFFFFFF000000FF0000000000000000000000FF000000FF000000FFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF848484FF000000FF8484 84FFFFFFFFFF000000FF0000000000000000000000FF000000FFC6C6C6FFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF848484FF000000FF000000FF8484 84FFFFFFFFFF000000FF0000000000000000000000FF000000FFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFF848484FF000000FF000000FF000000FF0000 00FFFFFFFFFF000000FF0000000000000000000000FF000000FFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFF848484FF000000FF000000FF000000FF000000FF0000 00FFFFFFFFFF000000FF0000000000000000000000FF000000FFC6C6C6FFFFFF FFFFFFFFFFFF848484FF000000FF000000FF000000FF000000FF000000FF8484 84FFFFFFFFFF000000FF0000000000000000000000FF000000FF000000FFFFFF FFFF848484FF000000FF000000FF000000FF000000FF000000FF000000FFFFFF FFFFFFFFFFFF000000FF0000000000000000000000FF000000FF000000FF8484 84FF000000FF000000FF000000FF000000FF000000FF000000FFFFFFFFFFFFFF FFFFFFFFFFFF000000FF0000000000000000000000FF000000FF848484FFFFFF FFFF848484FF848484FF000000FF000000FF848484FFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF000000FF0000000000000000000000FF848484FFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF000000FF0000000000000000000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF00000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000 } end object Timer: TTimer Interval = 200 OnTimer = TimerTimer left = 122 top = 84 end object PopupMenu: TPopupMenu Images = ImageList OnPopup = PopupMenuPopup left = 242 top = 84 object mnLoad: TMenuItem Caption = 'Load...' Bitmap.Data = { 36040000424D3604000000000000360000002800000010000000100000000100 2000000000000004000064000000640000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF0000000000000000000000000000000000000000000000FF0000 00FF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B 7BFF007B7BFF000000FF00000000000000000000000000000000000000FF00FF FFFF000000FF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B 7BFF007B7BFF007B7BFF000000FF000000000000000000000000000000FFFFFF FFFF00FFFFFF000000FF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B 7BFF007B7BFF007B7BFF007B7BFF000000FF0000000000000000000000FF00FF FFFFFFFFFFFF00FFFFFF000000FF007B7BFF007B7BFF007B7BFF007B7BFF007B 7BFF007B7BFF007B7BFF007B7BFF007B7BFF000000FF00000000000000FFFFFF FFFF00FFFFFFFFFFFFFF00FFFFFF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF00FF FFFFFFFFFFFF00FFFFFFFFFFFFFF00FFFFFFFFFFFFFF00FFFFFFFFFFFFFF00FF FFFF000000FF0000000000000000000000000000000000000000000000FFFFFF FFFF00FFFFFFFFFFFFFF00FFFFFFFFFFFFFF00FFFFFFFFFFFFFF00FFFFFFFFFF FFFF000000FF0000000000000000000000000000000000000000000000FF00FF FFFFFFFFFFFF00FFFFFF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF0000000000000000000000000000000000000000000000000000 00FF000000FF000000FF00000000000000000000000000000000000000000000 00000000000000000000000000FF000000FF000000FF00000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000FF000000FF00000000000000000000 0000000000000000000000000000000000000000000000000000000000FF0000 00000000000000000000000000FF00000000000000FF00000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00FF000000FF000000FF00000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000 } ImageIndex = 0 OnClick = LoadClick end object mnSave: TMenuItem Caption = 'Save...' Bitmap.Data = { 36040000424D3604000000000000360000002800000010000000100000000100 2000000000000004000064000000640000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF00000000000000000000 00FF007B7BFF007B7BFF000000FF000000FF000000FF000000FF000000FF0000 00FFBDBDBDFFBDBDBDFF000000FF007B7BFF000000FF00000000000000000000 00FF007B7BFF007B7BFF000000FF000000FF000000FF000000FF000000FF0000 00FFBDBDBDFFBDBDBDFF000000FF007B7BFF000000FF00000000000000000000 00FF007B7BFF007B7BFF000000FF000000FF000000FF000000FF000000FF0000 00FFBDBDBDFFBDBDBDFF000000FF007B7BFF000000FF00000000000000000000 00FF007B7BFF007B7BFF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF007B7BFF000000FF00000000000000000000 00FF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B7BFF007B 7BFF007B7BFF007B7BFF007B7BFF007B7BFF000000FF00000000000000000000 00FF007B7BFF007B7BFF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF007B7BFF007B7BFF000000FF00000000000000000000 00FF007B7BFF000000FFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBD BDFFBDBDBDFFBDBDBDFF000000FF007B7BFF000000FF00000000000000000000 00FF007B7BFF000000FFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBD BDFFBDBDBDFFBDBDBDFF000000FF007B7BFF000000FF00000000000000000000 00FF007B7BFF000000FFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBD BDFFBDBDBDFFBDBDBDFF000000FF007B7BFF000000FF00000000000000000000 00FF007B7BFF000000FFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBD BDFFBDBDBDFFBDBDBDFF000000FF007B7BFF000000FF00000000000000000000 00FF007B7BFF000000FFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBD BDFFBDBDBDFFBDBDBDFF000000FF000000FF000000FF00000000000000000000 00FF007B7BFF000000FFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBD BDFFBDBDBDFFBDBDBDFF000000FFBDBDBDFF000000FF00000000000000000000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF00000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000 } ImageIndex = 1 OnClick = SaveClick end object mnClear: TMenuItem Caption = 'Clear' Bitmap.Data = { 36040000424D3604000000000000360000002800000010000000100000000100 2000000000000004000064000000640000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000007BFFFFFFFFFF00000000000000000000 00000000000000007BFFFFFFFFFF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000007BFF00007BFF00007BFFFFFFFFFF0000000000000000000000000000 0000000000000000000000007BFFFFFFFFFF0000000000000000000000000000 000000007BFF00007BFF00007BFFFFFFFFFF0000000000000000000000000000 00000000000000007BFFFFFFFFFF000000000000000000000000000000000000 00000000000000007BFF00007BFF00007BFFFFFFFFFF00000000000000000000 000000007BFF00007BFFFFFFFFFF000000000000000000000000000000000000 0000000000000000000000007BFF00007BFF00007BFFFFFFFFFF000000000000 7BFF00007BFFFFFFFFFF00000000000000000000000000000000000000000000 000000000000000000000000000000007BFF00007BFF00007BFF00007BFF0000 7BFFFFFFFFFF0000000000000000000000000000000000000000000000000000 00000000000000000000000000000000000000007BFF00007BFF00007BFFFFFF FFFF000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000007BFF00007BFF00007BFF00007BFF0000 7BFFFFFFFFFF0000000000000000000000000000000000000000000000000000 0000000000000000000000007BFF00007BFF00007BFFFFFFFFFF000000000000 7BFFFFFFFFFF0000000000000000000000000000000000000000000000000000 000000007BFF00007BFF00007BFF00007BFFFFFFFFFF00000000000000000000 000000007BFF00007BFFFFFFFFFF000000000000000000000000000000000000 7BFF00007BFF00007BFF00007BFFFFFFFFFF0000000000000000000000000000 00000000000000007BFF00007BFFFFFFFFFF0000000000000000000000000000 7BFF00007BFFFFFFFFFF00000000000000000000000000000000000000000000 0000000000000000000000007BFF00007BFFFFFFFFFF00000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000 } ImageIndex = 2 OnClick = ClearClick end object mnSeparator: TMenuItem Caption = '-' end object mnCopy: TMenuItem Caption = 'Copy' Bitmap.Data = { 36040000424D3604000000000000360000002800000010000000100000000100 2000000000000004000064000000640000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000007B0000FF7B0000FF7B0000FF7B00 00FF7B0000FF7B0000FF7B0000FF7B0000FF7B0000FF00000000000000000000 0000000000000000000000000000000000007B0000FFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B0000FF00000000000000000000 0000000000000000000000000000000000007B0000FFFFFFFFFF000000FF0000 00FF000000FF000000FF000000FFFFFFFFFF7B0000FF00000000000000FF0000 00FF000000FF000000FF000000FF000000FF7B0000FFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B0000FF00000000000000FFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B0000FFFFFFFFFF000000FF0000 00FF000000FF000000FF000000FFFFFFFFFF7B0000FF00000000000000FFFFFF FFFF000000FF000000FF000000FF000000FF7B0000FFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B0000FF00000000000000FFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B0000FFFFFFFFFF000000FF0000 00FFFFFFFFFF7B0000FF7B0000FF7B0000FF7B0000FF00000000000000FFFFFF FFFF000000FF000000FF000000FF000000FF7B0000FFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF7B0000FFFFFFFFFF7B0000FF0000000000000000000000FFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B0000FFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF7B0000FF7B0000FF000000000000000000000000000000FFFFFF FFFF000000FF000000FFFFFFFFFF000000FF7B0000FF7B0000FF7B0000FF7B00 00FF7B0000FF7B0000FF00000000000000000000000000000000000000FFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFF000000FF000000000000 0000000000000000000000000000000000000000000000000000000000FFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFF000000FF000000FF00000000000000000000 0000000000000000000000000000000000000000000000000000000000FF0000 00FF000000FF000000FF000000FF000000FF0000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000 } ImageIndex = 3 OnClick = CopyClick end object mnPaste: TMenuItem Caption = 'Paste' Bitmap.Data = { 36040000424D3604000000000000360000002800000010000000100000000100 2000000000000004000064000000640000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000007B0000FF7B0000FF7B0000FF7B00 00FF7B0000FF7B0000FF7B0000FF7B0000FF7B0000FF7B0000FF000000000000 00FF000000FF000000FF000000FF000000FF7B0000FFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B0000FF000000FF7B7B 7BFF007B7BFF7B7B7BFF007B7BFF7B7B7BFF7B0000FFFFFFFFFF7B0000FF7B00 00FF7B0000FF7B0000FF7B0000FF7B0000FFFFFFFFFF7B0000FF000000FF007B 7BFF7B7B7BFF007B7BFF7B7B7BFF007B7BFF7B0000FFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7B0000FF000000FF7B7B 7BFF007B7BFF7B7B7BFF007B7BFF7B7B7BFF7B0000FFFFFFFFFF7B0000FF7B00 00FF7B0000FFFFFFFFFF7B0000FF7B0000FF7B0000FF7B0000FF000000FF007B 7BFF7B7B7BFF007B7BFF7B7B7BFF007B7BFF7B0000FFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFF7B0000FFFFFFFFFF7B0000FF00000000000000FF7B7B 7BFF007B7BFF7B7B7BFF007B7BFF7B7B7BFF7B0000FFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFF7B0000FF7B0000FF0000000000000000000000FF007B 7BFF7B7B7BFF007B7BFF7B7B7BFF007B7BFF7B0000FF7B0000FF7B0000FF7B00 00FF7B0000FF7B0000FF7B0000FF000000FF0000000000000000000000FF7B7B 7BFF007B7BFF7B7B7BFF007B7BFF7B7B7BFF007B7BFF7B7B7BFF007B7BFF7B7B 7BFF007B7BFF7B7B7BFF007B7BFF000000FF0000000000000000000000FF007B 7BFF7B7B7BFF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF7B7B7BFF7B7B7BFF000000FF0000000000000000000000FF7B7B 7BFF7B7B7BFF000000FFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBDBDFFBDBD BDFF000000FF7B7B7BFF007B7BFF000000FF0000000000000000000000FF007B 7BFF7B7B7BFF007B7BFF000000FF00FFFFFF000000FF000000FF00FFFFFF0000 00FF7B7B7BFF007B7BFF7B7B7BFF000000FF0000000000000000000000000000 00FF000000FF000000FF000000FF000000FF00FFFFFF00FFFFFF000000FF0000 00FF000000FF000000FF000000FF000000000000000000000000000000000000 0000000000000000000000000000000000FF000000FF000000FF000000FF0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000 } ImageIndex = 4 OnClick = PasteClick end object mnSeparator2: TMenuItem Caption = '-' end object mnInvert: TMenuItem Caption = 'Invert' Bitmap.Data = { 36040000424D3604000000000000360000002800000010000000100000000100 2000000000000004000064000000640000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF00000000000000000000 00FF848484FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000FF00000000000000000000 00FF000000FF848484FFFFFFFFFF848484FF848484FF000000FF000000FF8484 84FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000FF00000000000000000000 00FF000000FF000000FF848484FF000000FF000000FF000000FF000000FF0000 00FF000000FFFFFFFFFFFFFFFFFFFFFFFFFF000000FF00000000000000000000 00FF000000FF000000FFFFFFFFFF848484FF000000FF000000FF000000FF0000 00FF000000FF000000FFFFFFFFFFFFFFFFFF000000FF00000000000000000000 00FF000000FFC6C6C6FFFFFFFFFFFFFFFFFF848484FF000000FF000000FF0000 00FF000000FF000000FF848484FFFFFFFFFF000000FF00000000000000000000 00FF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF848484FF000000FF0000 00FF000000FF000000FF000000FFFFFFFFFF000000FF00000000000000000000 00FF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF848484FF0000 00FF000000FF000000FF000000FFFFFFFFFF000000FF00000000000000000000 00FF000000FFC6C6C6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8484 84FF000000FF000000FF848484FFFFFFFFFF000000FF00000000000000000000 00FF000000FF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFF848484FF000000FF848484FFFFFFFFFF000000FF00000000000000000000 00FF000000FF000000FF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF FFFFFFFFFFFF848484FFFFFFFFFFFFFFFFFF000000FF00000000000000000000 00FF000000FF000000FF000000FF000000FFC6C6C6FFFFFFFFFFFFFFFFFFC6C6 C6FF000000FF000000FF848484FFFFFFFFFF000000FF00000000000000000000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF848484FF000000FF00000000000000000000 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000 00FF000000FF000000FF000000FF000000FF000000FF00000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000 } ImageIndex = 5 OnClick = mnInvertClick end end end |
Added src/graphics32/GR32_Dsgn_Bitmap.lrs.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 | { This is an automatically generated lazarus resource file } LazarusResources.Add('TPictureEditorForm','FORMDATA',[ 'TPF0'#18'TPictureEditorForm'#17'PictureEditorForm'#4'Left'#3#247#0#6'Height' +#3#184#1#3'Top'#3'e'#1#5'Width'#3'Z'#1#18'HorzScrollBar.Page'#3'Y'#1#18'Vert' +'ScrollBar.Page'#3#183#1#13'ActiveControl'#7#8'OKButton'#11'BorderIcons'#11 +#12'biSystemMenu'#0#11'BorderStyle'#7#13'bsSizeToolWin'#7'Caption'#6#15'Bitm' +'ap32 Editor'#12'ClientHeight'#3#184#1#11'ClientWidth'#3'Z'#1#21'Constraints' +'.MinHeight'#3#200#0#20'Constraints.MinWidth'#3'6'#1#11'Font.Height'#2#245#9 +'Font.Name'#6#6'Tahoma'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#6 +'0.9.31'#0#6'TBevel'#6'Bevel1'#4'Left'#2#0#6'Height'#2#6#3'Top'#2'3'#5'Width' +#3'Z'#1#5'Align'#7#5'alTop'#5'Shape'#7#9'bsTopLine'#5'Style'#7#8'bsRaised'#0 +#0#8'TToolBar'#7'ToolBar'#4'Left'#2#0#6'Height'#2'('#3'Top'#2#0#5'Width'#3'Z' +#1#8'AutoSize'#9#11'BorderWidth'#2#1#12'ButtonHeight'#2'$'#11'ButtonWidth'#2 +'6'#7'Caption'#6#7'ToolBar'#11'EdgeBorders'#11#5'ebTop'#8'ebBottom'#0#6'Imag' +'es'#7#9'ImageList'#12'ShowCaptions'#9#8'TabOrder'#2#0#0#11'TToolButton'#4'L' +'oad'#4'Left'#2#1#3'Top'#2#2#7'Caption'#6#12' Load '#10'ImageIndex'#2#0 +#7'OnClick'#7#9'LoadClick'#0#0#11'TToolButton'#4'Save'#4'Left'#2'8'#3'Top'#2 +#2#7'Caption'#6#4'Save'#10'ImageIndex'#2#1#7'OnClick'#7#9'SaveClick'#0#0#11 +'TToolButton'#5'Clear'#4'Left'#2'n'#3'Top'#2#2#7'Caption'#6#5'Clear'#10'Imag' +'eIndex'#2#2#7'OnClick'#7#10'ClearClick'#0#0#11'TToolButton'#11'ToolButton2' +#4'Left'#3#164#0#3'Top'#2#2#5'Width'#2#10#7'Caption'#6#11'ToolButton2'#10'Im' +'ageIndex'#2#3#5'Style'#7#12'tbsSeparator'#0#0#11'TToolButton'#4'Copy'#4'Lef' +'t'#3#174#0#3'Top'#2#2#7'Caption'#6#4'Copy'#10'ImageIndex'#2#3#7'OnClick'#7#9 +'CopyClick'#0#0#11'TToolButton'#5'Paste'#4'Left'#3#228#0#3'Top'#2#2#7'Captio' +'n'#6#5'Paste'#10'ImageIndex'#2#4#7'OnClick'#7#10'PasteClick'#0#0#0#12'TPage' +'Control'#11'PageControl'#4'Left'#2#0#6'Height'#3'^'#1#3'Top'#2'9'#5'Width'#3 +'Z'#1#10'ActivePage'#7#10'ImageSheet'#5'Align'#7#8'alClient'#8'TabIndex'#2#0 +#8'TabOrder'#2#1#11'TabPosition'#7#8'tpBottom'#0#9'TTabSheet'#10'ImageSheet' +#7'Caption'#6#9'RGB Image'#0#0#9'TTabSheet'#10'AlphaSheet'#7'Caption'#6#13'A' +'lpha Channel'#10'ImageIndex'#2#1#0#0#0#6'TPanel'#6'Panel1'#4'Left'#2#0#6'He' +'ight'#2'!'#3'Top'#3#151#1#5'Width'#3'Z'#1#5'Align'#7#8'alBottom'#10'BevelOu' +'ter'#7#6'bvNone'#12'ClientHeight'#2'!'#11'ClientWidth'#3'Z'#1#8'TabOrder'#2 +#2#0#6'TLabel'#6'Label1'#4'Left'#2#8#6'Height'#2#14#3'Top'#2#8#5'Width'#2#31 +#7'Anchors'#11#6'akLeft'#8'akBottom'#0#7'Caption'#6#5'Magn:'#11'ParentColor' +#8#0#0#7'TButton'#8'OKButton'#4'Left'#3#194#0#6'Height'#2#23#3'Top'#2#6#5'Wi' +'dth'#2'@'#7'Anchors'#11#7'akRight'#8'akBottom'#0#25'BorderSpacing.InnerBord' +'er'#2#4#7'Caption'#6#2'OK'#7'Default'#9#11'ModalResult'#2#1#8'TabOrder'#2#0 +#0#0#7'TButton'#6'Cancel'#4'Left'#3#13#1#6'Height'#2#23#3'Top'#2#6#5'Width'#2 +'A'#7'Anchors'#11#7'akRight'#8'akBottom'#0#25'BorderSpacing.InnerBorder'#2#4 +#6'Cancel'#9#7'Caption'#6#6'Cancel'#11'ModalResult'#2#2#8'TabOrder'#2#1#0#0#9 +'TComboBox'#9'MagnCombo'#4'Left'#2'0'#6'Height'#2#21#3'Top'#2#7#5'Width'#2'I' +#7'Anchors'#11#6'akLeft'#8'akBottom'#0#10'ItemHeight'#2#13#13'Items.Strings' +#1#6#6' 25 %'#6#6' 50 %'#6#5'100 %'#6#5'200 %'#6#5'400 %'#6#5'800 %'#6#6'T' +'o Fit'#0#8'OnChange'#7#15'MagnComboChange'#5'Style'#7#14'csDropDownList'#8 +'TabOrder'#2#2#0#0#0#6'TPanel'#6'Panel2'#4'Left'#2#0#6'Height'#2#11#3'Top'#2 +'('#5'Width'#3'Z'#1#5'Align'#7#5'alTop'#9'Alignment'#7#13'taLeftJustify'#10 +'BevelOuter'#7#6'bvNone'#5'Color'#7#8'clInfoBk'#11'Font.Height'#2#248#9'Font' +'.Name'#6#11'Small Fonts'#11'ParentColor'#8#10'ParentFont'#8#8'TabOrder'#2#3 +#0#0#10'TImageList'#9'ImageList'#4'left'#3#184#0#3'top'#2'R'#6'Bitmap'#10#14 +#24#0#0'Li'#6#0#0#0#16#0#0#0#16#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#0#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#0#0#0#0#255#0#255#255#255#255#255#255#255#0#255#255#255 +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#0#255#255#255 +#255#255#255#255#0#255#255#255#255#255#255#255#0#255#255#255#255#255#255#255 +#0#255#255#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#255#0#255#255#255#255#255#255#255#0#255#255#255#255#255#255#255#0 +#255#255#255#255#255#255#255#0#255#255#255#255#255#255#255#0#255#255#255#0#0 +#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#0 ,#255#255#255#255#255#255#255#0#255#255#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 +#0#0#0#255#0#255#255#255#255#255#255#255#0#255#255#255#0#0#0#255#0'{{'#255#0 +'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{' +#255#0#0#0#255#0#0#0#0#0#0#0#255#255#255#255#255#0#255#255#255#0#0#0#255#0'{' +'{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255 +#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#255#255#255#0#0#0#255#0'{{' +#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0 +'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0'{{'#255#0'{' +'{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255 +#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255 +#0#0#0#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255 +#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#0#0#0#255 +#189#189#189#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0#0#0#255#189 +#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255 +#189#189#189#255#189#189#189#255#189#189#189#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0#0#0#255#189#189#189#255#189#189 +#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189 +#189#189#255#189#189#189#255#0#0#0#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0 +#0#0#255#0'{{'#255#0#0#0#255#189#189#189#255#189#189#189#255#189#189#189#255 +#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189 +#255#0#0#0#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0#0#0 +#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189 +#189#255#189#189#189#255#189#189#189#255#189#189#189#255#0#0#0#255#0'{{'#255 +#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0#0#0#255#189#189#189#255#189 +#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255 +#189#189#189#255#189#189#189#255#0#0#0#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0 +#0#0#0#0#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0#0#0 +#0#0#0#0#0#0#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255 +#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0 +#0#0#0#0#0#0#0#0#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0'{{'#255#0#0#0#255#0 +#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0#255#0#0#0#255#0 +#0#0#255#0#0#0#255#0#0#0#255#189#189#189#255#189#189#189#255#0#0#0#255#0'{{' +#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#189#189#189#255#189#189#189#255 +#0#0#0#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0'{{'#255 +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#189#189#189#255 +#189#189#189#255#0#0#0#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#255#255#255 +#255#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0#0'{'#255#0#0'{'#255#255#255#255 +#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#255#255 +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0#0'{'#255#0#0 +'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#255#255 +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0 +#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0'{'#255#255#255#255#255#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0'{'#255#0#0'{'#255#0#0'{'#255#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0 ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0'{'#255#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0 +#0'{'#255#0#0'{'#255#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255 +#0#0'{'#255#255#255#255#255#0#0#0#0#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0 +#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#255 +#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0 +#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255 +#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{' +#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{' +#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#255 +#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 +#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#0#0#0#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255 +#255#0#0#0#255#0#0#0#255#255#255#255#255#0#0#0#255'{'#0#0#255'{'#0#0#255'{'#0 +#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255'{'#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255'{'#0#0#255'{'#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'{'#0#0#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255'{'#0#0#255#255#255#255#255'{'#0 +#0#255#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255'{'#0#0#255#255#255#255#255#0#0#0#255#0#0 +#0#255#255#255#255#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0#0#0 +#0#0#255#255#255#255#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'{'#0#0#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255'{'#0#0#255#0#0#0#0#0#0#0#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255'{'#0#0 +#255#255#255#255#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#255 +#255#255#255'{'#0#0#255#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255'{'#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255'{'#0#0#255#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#0#0#255#255#255#255#255 +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#255#255#255#255'{'#0#0#255 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#0#0#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255'{'#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{' +#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0 +#0#0#255#0#0#0#255#0#255#255#255#0#255#255#255#0#0#0#255#0#0#0#255#0#0#0#255 +#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255'{{{'#255#0 +'{{'#255#0#0#0#255#0#255#255#255#0#0#0#255#0#0#0#255#0#255#255#255#0#0#0#255 +'{{{'#255#0'{{'#255'{{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255'{{{'#255'{{' ,'{'#255#0#0#0#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189 +#255#189#189#189#255#189#189#189#255#0#0#0#255'{{{'#255#0'{{'#255#0#0#0#255#0 +#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255'{{{'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'{{{'#255'{{{'#255#0#0#0#255#0 +#0#0#0#0#0#0#0#0#0#0#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{{{'#255#0'{{' +#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255#0#0#0#255#0#0#0 +#0#0#0#0#0#0#0#0#255#0'{{'#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{'#0#0 +#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0 +#255#0#0#0#0#0#0#0#0#0#0#0#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{{{'#255 +'{'#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255'{'#0#0#255'{'#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255'{' +'{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{'#0#0#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255'{'#0#0#255#255#255#255 +#255'{'#0#0#255#0#0#0#0#0#0#0#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{{{' +#255'{'#0#0#255#255#255#255#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#255#255#255 +#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0#255#0'{{'#255'{{{'#255 +#0'{{'#255'{{{'#255#0'{{'#255'{'#0#0#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255'{'#0#0#255#0#0#0#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255 +'{{{'#255'{'#0#0#255#255#255#255#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0 +#255'{'#0#0#255'{'#0#0#255#255#255#255#255'{'#0#0#255#0#0#0#0#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255'{'#0#0#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255'{'#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0 +#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0 +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#132#132#132#255#0#0#0#255#0#0#0 +#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#198#198#198#255 +#255#255#255#255#255#255#255#255#198#198#198#255#0#0#0#255#0#0#0#255#132#132 +#132#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#132#132#132#255#255#255#255#255#255#255 +#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#132#132#132#255#0#0#0#255#132#132#132#255#255#255#255#255#0#0#0#255 +#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#198#198#198#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#132#132#132#255#0#0 +#0#255#0#0#0#255#132#132#132#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0 +#0#0#255#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#132#132#132#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#132#132#132#255#0#0 +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#255#255#255#255#0#0#0#255#0#0 +#0#0#0#0#0#0#0#0#0#255#0#0#0#255#198#198#198#255#255#255#255#255#255#255#255 +#255#132#132#132#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#132 +#132#132#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0 +#0#0#255#255#255#255#255#132#132#132#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#255#255#255#255#255#255#255#255#0#0#0#255#0#0#0#0#0 +#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#132#132#132#255#0#0#0#255#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#255#255#255#255#255#255#255#255#255#255 +#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#132#132#132#255#255 +#255#255#255#132#132#132#255#132#132#132#255#0#0#0#255#0#0#0#255#132#132#132 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0 +#255#0#0#0#0#0#0#0#0#0#0#0#255#132#132#132#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 +#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 ,#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#6 +'TTimer'#5'Timer'#8'Interval'#3#200#0#7'OnTimer'#7#10'TimerTimer'#4'left'#2 +'z'#3'top'#2'T'#0#0#10'TPopupMenu'#9'PopupMenu'#6'Images'#7#9'ImageList'#7'O' +'nPopup'#7#14'PopupMenuPopup'#4'left'#3#242#0#3'top'#2'T'#0#9'TMenuItem'#6'm' +'nLoad'#7'Caption'#6#7'Load...'#11'Bitmap.Data'#10':'#4#0#0'6'#4#0#0'BM6'#4#0 +#0#0#0#0#0'6'#0#0#0'('#0#0#0#16#0#0#0#16#0#0#0#1#0' '#0#0#0#0#0#0#4#0#0'd'#0 +#0#0'd'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255 +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0 +'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{' +#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#255#255 +#255#0#0#0#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0 +'{{'#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255 +#255#255#255#0#255#255#255#0#0#0#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255 +#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0 +#0#0#0#255#0#255#255#255#255#255#255#255#0#255#255#255#0#0#0#255#0'{{'#255#0 +'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{' +#255#0#0#0#255#0#0#0#0#0#0#0#255#255#255#255#255#0#255#255#255#255#255#255 +#255#0#255#255#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#255#255 +#255#255#255#255#255#0#255#255#255#255#255#255#255#0#255#255#255#255#255#255 +#255#0#255#255#255#255#255#255#255#0#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#0#255#255#255#255#255#255 +#255#0#255#255#255#255#255#255#255#0#255#255#255#255#255#255#255#0#255#255 +#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#255#0#255#255#255#255#255#255#255#0#255#255#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#255#0#0#0#0#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#10'Imag' +'eIndex'#2#0#7'OnClick'#7#9'LoadClick'#0#0#9'TMenuItem'#6'mnSave'#7'Caption' +#6#7'Save...'#11'Bitmap.Data'#10':'#4#0#0'6'#4#0#0'BM6'#4#0#0#0#0#0#0'6'#0#0 +#0'('#0#0#0#16#0#0#0#16#0#0#0#1#0' '#0#0#0#0#0#0#4#0#0'd'#0#0#0'd'#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0 +#0#0#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#189#189#189#255#189#189#189#255#0#0#0#255#0'{{'#255#0#0#0#255 +#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0#255#0#0#0#255 +#0#0#0#255#0#0#0#255#0#0#0#255#189#189#189#255#189#189#189#255#0#0#0#255#0'{' +'{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#189#189#189#255#189#189#189 +#255#0#0#0#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0'{{' +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 +#0#0#255#0#0#0#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0 +'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{'#255#0'{{' +#255#0'{{'#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{' +#255#0'{{'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 +#0#0#255#0#0#0#255#0'{{'#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0 +'{{'#255#0#0#0#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189 +#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#0#0 +#0#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0#0#0#255#189 +#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255 ,#189#189#189#255#189#189#189#255#189#189#189#255#0#0#0#255#0'{{'#255#0#0#0 +#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0#0#0#255#189#189#189#255#189#189 +#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189 +#189#189#255#189#189#189#255#0#0#0#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0 +#0#0#255#0'{{'#255#0#0#0#255#189#189#189#255#189#189#189#255#189#189#189#255 +#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189 +#255#0#0#0#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0#0#0 +#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189 +#189#255#189#189#189#255#189#189#189#255#189#189#189#255#0#0#0#255#0#0#0#255 +#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255#0#0#0#255#189#189#189#255#189 +#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255#189#189#189#255 +#189#189#189#255#189#189#189#255#0#0#0#255#189#189#189#255#0#0#0#255#0#0#0#0 +#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#10'ImageIndex'#2#1 +#7'OnClick'#7#9'SaveClick'#0#0#9'TMenuItem'#7'mnClear'#7'Caption'#6#5'Clear' +#11'Bitmap.Data'#10':'#4#0#0'6'#4#0#0'BM6'#4#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#16 +#0#0#0#16#0#0#0#1#0' '#0#0#0#0#0#0#4#0#0'd'#0#0#0'd'#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#255#255#255 +#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0#0'{'#255#255#255#255#255#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0#0'{'#255#255 +#255#255#255#0#0#0#0#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255 +#0#0'{'#255#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0 +'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0#0'{' +#255#0#0'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0#0'{'#255#255 +#255#255#255#0#0#0#0#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0#0'{'#255#0#0'{'#255#255 +#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#255#255#255#255#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#0#0'{'#255#0#0'{'#255 +#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{' +#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#255#0#0'{'#255#255#255 +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +'{'#255#0#0'{'#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#10'ImageIndex'#2#2#7'OnClick'#7#10'ClearClick'#0#0#9'TMen' +'uItem'#11'mnSeparator'#7'Caption'#6#1'-'#0#0#9'TMenuItem'#6'mnCopy'#7'Capti' +'on'#6#4'Copy'#11'Bitmap.Data'#10':'#4#0#0'6'#4#0#0'BM6'#4#0#0#0#0#0#0'6'#0#0 +#0'('#0#0#0#16#0#0#0#16#0#0#0#1#0' '#0#0#0#0#0#0#4#0#0'd'#0#0#0'd'#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0 +#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0'{'#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255'{'#0#0#255#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'{'#0#0#255#255#255#255 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#255#255#255#255'{'#0#0 ,#255#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'{'#0 +#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255'{'#0#0#255#0#0#0#0#0#0#0#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +'{'#0#0#255#255#255#255#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 +#255#255#255#255'{'#0#0#255#0#0#0#0#0#0#0#255#255#255#255#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255'{'#0#0#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255'{'#0 +#0#255#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255'{'#0#0#255#255#255#255#255#0#0#0#255#0#0#0#255 +#255#255#255#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0#0#0#0#0 +#255#255#255#255#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'{'#0#0#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255'{'#0#0#255#255 +#255#255#255'{'#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255'{'#0#0#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255'{'#0#0#255'{'#0#0#255#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#0#0#0#255#0#0#0#255#255#255 +#255#255#0#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{' +#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#0#0#0#255#255#255#255#255#0#0#0#255 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0#255#0 +#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#10'ImageIndex'#2#3#7'OnClick'#7 +#9'CopyClick'#0#0#9'TMenuItem'#7'mnPaste'#7'Caption'#6#5'Paste'#11'Bitmap.Da' +'ta'#10':'#4#0#0'6'#4#0#0'BM6'#4#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#16#0#0#0#16#0 +#0#0#1#0' '#0#0#0#0#0#0#4#0#0'd'#0#0#0'd'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255 +'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0#0#0#0#0#255#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255'{'#0#0#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255'{'#0#0#255#0#0#0#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{{{' +#255'{'#0#0#255#255#255#255#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255 +'{'#0#0#255'{'#0#0#255#255#255#255#255'{'#0#0#255#0#0#0#255#0'{{'#255'{{{' +#255#0'{{'#255'{{{'#255#0'{{'#255'{'#0#0#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255'{'#0#0#255#0#0#0#255'{{{'#255#0'{{'#255'{{{'#255#0'{{' +#255'{{{'#255'{'#0#0#255#255#255#255#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#255 +#255#255#255'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0#255#0'{{'#255 +'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{'#0#0#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255'{'#0#0#255#255#255#255 +#255'{'#0#0#255#0#0#0#0#0#0#0#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{{{' +#255'{'#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255'{'#0#0#255'{'#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{' +#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{'#0#0#255'{'#0#0#255'{'#0#0#255 +'{'#0#0#255'{'#0#0#255'{'#0#0#255'{'#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0 +#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255'{{{'#255#0'{{' +#255'{{{'#255#0'{{'#255'{{{'#255#0'{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0 +#255#0'{{'#255'{{{'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255'{{{'#255'{{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0 +#255'{{{'#255'{{{'#255#0#0#0#255#189#189#189#255#189#189#189#255#189#189#189 +#255#189#189#189#255#189#189#189#255#189#189#189#255#0#0#0#255'{{{'#255#0'{{' +#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0'{{'#255'{{{'#255#0'{{'#255#0#0#0 +#255#0#255#255#255#0#0#0#255#0#0#0#255#0#255#255#255#0#0#0#255'{{{'#255#0'{{' +#255'{{{'#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255 +#0#0#0#255#0#0#0#255#0#255#255#255#0#255#255#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#10'ImageIndex'#2#4#7'OnClick'#7#10'PasteClick'#0#0#9'TMenuItem'#12 +'mnSeparator2'#7'Caption'#6#1'-'#0#0#9'TMenuItem'#8'mnInvert'#7'Caption'#6#6 +'Invert'#11'Bitmap.Data'#10':'#4#0#0'6'#4#0#0'BM6'#4#0#0#0#0#0#0'6'#0#0#0'(' +#0#0#0#16#0#0#0#16#0#0#0#1#0' '#0#0#0#0#0#0#4#0#0'd'#0#0#0'd'#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255 +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0 +#255#132#132#132#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0 +#255#0#0#0#255#132#132#132#255#255#255#255#255#132#132#132#255#132#132#132 +#255#0#0#0#255#0#0#0#255#132#132#132#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0 +#0#0#255#132#132#132#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 +#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0#255#0#0#0#0#0 +#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#255#255#255#255#132#132#132#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#255#255#255#255#255 +#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#198#198#198#255 +#255#255#255#255#255#255#255#255#132#132#132#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#132#132#132#255#255#255#255#255#0#0#0#255#0#0#0#0#0 +#0#0#0#0#0#0#255#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#132#132#132#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 +#0#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#132 +#132#132#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#255#255#255#255#0#0#0 +#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#198#198#198#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#132#132#132#255 +#0#0#0#255#0#0#0#255#132#132#132#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0 +#0#0#0#0#255#0#0#0#255#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#255#132#132#132#255#0#0#0 +#255#132#132#132#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0 +#0#255#0#0#0#255#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 +#255#255#255#255#255#255#255#255#255#255#255#255#132#132#132#255#255#255#255 +#255#255#255#255#255#0#0#0#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255 +#0#0#0#255#0#0#0#255#198#198#198#255#255#255#255#255#255#255#255#255#198#198 +#198#255#0#0#0#255#0#0#0#255#132#132#132#255#255#255#255#255#0#0#0#255#0#0#0 +#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#132#132#132#255#0#0#0 +#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 +#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#10'Imag' +'eIndex'#2#5#7'OnClick'#7#13'mnInvertClick'#0#0#0#0 ]); |
Added src/graphics32/GR32_Dsgn_Bitmap.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 | unit GR32_Dsgn_Bitmap; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LCLType, RtlConsts, Buttons, LazIDEIntf, PropEdits, ComponentEditors, {$ELSE} Windows, ExtDlgs, ToolWin, Registry, ImgList, Consts, DesignIntf, DesignEditors, VCLEditors, {$ENDIF} Forms, Controls, ComCtrls, ExtCtrls, StdCtrls, Graphics, Dialogs, Menus, SysUtils, Classes, Clipbrd, GR32, GR32_Image, GR32_Layers, GR32_Filters; type TPictureEditorForm = class(TForm) AlphaSheet: TTabSheet; Bevel1: TBevel; Cancel: TButton; Clear: TToolButton; Copy: TToolButton; ImageList: TImageList; ImageSheet: TTabSheet; Label1: TLabel; Load: TToolButton; MagnCombo: TComboBox; mnClear: TMenuItem; mnCopy: TMenuItem; mnInvert: TMenuItem; mnLoad: TMenuItem; mnPaste: TMenuItem; mnSave: TMenuItem; mnSeparator: TMenuItem; mnSeparator2: TMenuItem; OKButton: TButton; PageControl: TPageControl; Panel1: TPanel; Panel2: TPanel; Paste: TToolButton; PopupMenu: TPopupMenu; Save: TToolButton; Timer: TTimer; ToolBar: TToolBar; ToolButton2: TToolButton; procedure LoadClick(Sender: TObject); procedure SaveClick(Sender: TObject); procedure ClearClick(Sender: TObject); procedure CopyClick(Sender: TObject); procedure PasteClick(Sender: TObject); procedure TimerTimer(Sender: TObject); procedure PopupMenuPopup(Sender: TObject); procedure mnInvertClick(Sender: TObject); procedure MagnComboChange(Sender: TObject); protected {$IFDEF PLATFORM_INDEPENDENT} OpenDialog: TOpenDialog; SaveDialog: TSaveDialog; {$ELSE} OpenDialog: TOpenPictureDialog; SaveDialog: TSavePictureDialog; {$ENDIF} AlphaChannel: TImage32; RGBChannels: TImage32; procedure AlphaChannelMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); procedure RGBChannelsMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); function CurrentImage: TImage32; public constructor Create(AOwner: TComponent); override; end; TBitmap32Editor = class(TComponent) private FBitmap32: TBitmap32; FPicDlg: TPictureEditorForm; procedure SetBitmap32(Value: TBitmap32); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function Execute: Boolean; property Bitmap32: TBitmap32 read FBitmap32 write SetBitmap32; end; TBitmap32Property = class(TClassProperty {$IFDEF EXT_PROP_EDIT} , ICustomPropertyDrawing {$IFDEF COMPILER2005_UP}, ICustomPropertyDrawing80{$ENDIF} {$ENDIF} ) public procedure Edit; override; function GetAttributes: TPropertyAttributes; override; function GetValue: string; override; procedure SetValue(const Value: string); override; {$IFDEF EXT_PROP_EDIT} { ICustomPropertyDrawing } procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); procedure PropDrawValue(Canvas: TCanvas; const ARect: TRect; ASelected: Boolean); {$IFDEF COMPILER2005_UP} { ICustomPropertyDrawing80 } function PropDrawNameRect(const ARect: TRect): TRect; function PropDrawValueRect(const ARect: TRect): TRect; {$ENDIF} {$ENDIF} end; TImage32Editor = class(TComponentEditor) public procedure ExecuteVerb(Index: Integer); override; function GetVerb(Index: Integer): string; override; function GetVerbCount: Integer; override; end; implementation uses GR32_Resamplers; {$IFDEF FPC} {$R *.lfm} {$ELSE} {$R *.dfm} {$ENDIF} { TPictureEditorForm } procedure TPictureEditorForm.LoadClick(Sender: TObject); var Picture: TPicture; DoAlpha: Boolean; S: string; begin if OpenDialog.Execute then begin Picture := TPicture.Create; try Picture.LoadFromFile(OpenDialog.Filename); DoAlpha := False; if (Picture.Graphic is TBitmap) and (Picture.Bitmap.PixelFormat = pf32Bit) then begin S := ExtractFileName(OpenDialog.FileName); S := '''' + S + ''' file contains RGB and Alpha channels.'#13#10 + 'Do you want to load all channels?'; case MessageDlg(S, mtConfirmation, mbYesNoCancel, 0) of mrYes: DoAlpha := True; mrCancel: Exit; end; end; if DoAlpha then begin RGBChannels.Bitmap.Assign(Picture.Bitmap); AlphaToGrayscale(AlphaChannel.Bitmap, RGBChannels.Bitmap); RGBChannels.Bitmap.ResetAlpha; end else with CurrentImage do begin Bitmap.Assign(Picture); if CurrentImage = AlphaChannel then ColorToGrayscale(Bitmap, Bitmap); end; finally Picture.Free; end; end; end; procedure TPictureEditorForm.SaveClick(Sender: TObject); var Picture: TPicture; begin Picture := TPicture.Create; try Picture.Bitmap.Assign(CurrentImage.Bitmap); Picture.Bitmap.PixelFormat := pf24Bit; if Picture.Graphic <> nil then begin with SaveDialog do begin DefaultExt := GraphicExtension(TGraphicClass(Picture.Graphic.ClassType)); Filter := GraphicFilter(TGraphicClass(Picture.Graphic.ClassType)); if Execute then Picture.SaveToFile(Filename); end; end; finally Picture.Free; end; end; procedure TPictureEditorForm.ClearClick(Sender: TObject); begin CurrentImage.Bitmap.Delete; end; procedure TPictureEditorForm.CopyClick(Sender: TObject); begin Clipboard.Assign(CurrentImage.Bitmap); end; procedure TPictureEditorForm.PasteClick(Sender: TObject); begin if Clipboard.HasFormat(CF_BITMAP) or Clipboard.HasFormat(CF_PICTURE) then CurrentImage.Bitmap.Assign(Clipboard); if CurrentImage = AlphaChannel then ColorToGrayscale(CurrentImage.Bitmap, CurrentImage.Bitmap); end; procedure TPictureEditorForm.TimerTimer(Sender: TObject); begin Save.Enabled := not CurrentImage.Bitmap.Empty; Clear.Enabled := Save.Enabled; Copy.Enabled := Save.Enabled; Paste.Enabled := Clipboard.HasFormat(CF_BITMAP) or Clipboard.HasFormat(CF_PICTURE); end; function TPictureEditorForm.CurrentImage: TImage32; begin if PageControl.ActivePage = ImageSheet then Result := RGBChannels else Result := AlphaChannel; end; procedure TPictureEditorForm.PopupMenuPopup(Sender: TObject); begin mnSave.Enabled := not CurrentImage.Bitmap.Empty; mnClear.Enabled := Save.Enabled; mnCopy.Enabled := Save.Enabled; mnInvert.Enabled := Save.Enabled; mnPaste.Enabled := Clipboard.HasFormat(CF_BITMAP) or Clipboard.HasFormat(CF_PICTURE); end; procedure TPictureEditorForm.mnInvertClick(Sender: TObject); begin InvertRGB(CurrentImage.Bitmap, CurrentImage.Bitmap); end; procedure TPictureEditorForm.MagnComboChange(Sender: TObject); const MAGN: array[0..6] of Integer = (25, 50, 100, 200, 400, 800, -1); var S: Integer; begin S := MAGN[MagnCombo.ItemIndex]; if S = -1 then begin RGBChannels.ScaleMode := smResize; AlphaChannel.ScaleMode := smResize; end else begin RGBChannels.ScaleMode := smScale; RGBChannels.Scale := S / 100; AlphaChannel.ScaleMode := smScale; AlphaChannel.Scale := S / 100; end; end; constructor TPictureEditorForm.Create(AOwner: TComponent); begin inherited; RGBChannels := TImage32.Create(Self); RGBChannels.Parent := ImageSheet; RGBChannels.Align := alClient; RGBChannels.OnMouseMove := RGBChannelsMouseMove; AlphaChannel := TImage32.Create(Self); AlphaChannel.Parent := AlphaSheet; AlphaChannel.Align := alClient; AlphaChannel.OnMouseMove := AlphaChannelMouseMove; {$IFDEF PLATFORM_INDEPENDENT} OpenDialog := TOpenDialog.Create(Self); SaveDialog := TSaveDialog.Create(Self); {$ELSE} OpenDialog := TOpenPictureDialog.Create(Self); SaveDialog := TSavePictureDialog.Create(Self); {$ENDIF} MagnCombo.ItemIndex := 2; OpenDialog.Filter := GraphicFilter(TGraphic); SaveDialog.Filter := GraphicFilter(TGraphic); end; { TBitmap32Editor } constructor TBitmap32Editor.Create(AOwner: TComponent); begin inherited; FBitmap32 := TBitmap32.Create; FPicDlg := TPictureEditorForm.Create(Self); end; destructor TBitmap32Editor.Destroy; begin FBitmap32.Free; FPicDlg.Free; inherited; end; function TBitmap32Editor.Execute: Boolean; var B: TBitmap32; begin FPicDlg.RGBChannels.Bitmap := FBitmap32; AlphaToGrayscale(FPicDlg.AlphaChannel.Bitmap, FBitmap32); Result := (FPicDlg.ShowModal = mrOK); if Result then begin FBitmap32.Assign(FPicDlg.RGBChannels.Bitmap); FBitmap32.ResetAlpha; if not FBitmap32.Empty and not FPicDlg.AlphaChannel.Bitmap.Empty then begin B := TBitmap32.Create; try B.SetSize(FBitmap32.Width, FBitmap32.Height); FPicDlg.AlphaChannel.Bitmap.DrawTo(B, Rect(0, 0, B.Width, B.Height)); IntensityToAlpha(FBitmap32, B); finally B.Free; end; end; end; end; procedure TBitmap32Editor.SetBitmap32(Value: TBitmap32); begin try FBitmap32.Assign(Value); except on E: Exception do ShowMessage(E.Message); end; end; { TBitmap32Property } procedure TBitmap32Property.Edit; var BitmapEditor: TBitmap32Editor; begin try BitmapEditor := TBitmap32Editor.Create(nil); try {$IFDEF FPC} BitmapEditor.Bitmap32 := TBitmap32(GetObjectValue); {$ELSE} BitmapEditor.Bitmap32 := TBitmap32(Pointer(GetOrdValue)); {$ENDIF} if BitmapEditor.Execute then begin SetOrdValue(Longint(BitmapEditor.Bitmap32)); {$IFNDEF FPC} Designer.Modified; {$ENDIF} end; finally BitmapEditor.Free; end; except on E: Exception do ShowMessage(E.Message); end; end; function TBitmap32Property.GetAttributes: TPropertyAttributes; begin Result := [paDialog, paSubProperties]; end; function TBitmap32Property.GetValue: string; var Bitmap: TBitmap32; begin try Bitmap := TBitmap32(GetOrdValue); if (Bitmap = nil) or Bitmap.Empty then Result := srNone else Result := Format('%s [%d,%d]', [Bitmap.ClassName, Bitmap.Width, Bitmap.Height]); except on E: Exception do ShowMessage(E.Message); end; end; {$IFDEF EXT_PROP_EDIT} procedure TBitmap32Property.PropDrawValue(Canvas: TCanvas; const ARect: TRect; ASelected: Boolean); var Bitmap32: TBitmap32; TmpBitmap: TBitmap32; R: TRect; begin Bitmap32 := TBitmap32(GetOrdValue); if Bitmap32.Empty then DefaultPropertyDrawValue(Self, Canvas, ARect) else begin R := ARect; R.Right := R.Left + R.Bottom - R.Top; TmpBitmap := TBitmap32.Create; TmpBitmap.Width := R.Right - R.Left; TmpBitmap.Height := R.Bottom - R.Top; TDraftResampler.Create(TmpBitmap); TmpBitmap.Draw(TmpBitmap.BoundsRect, Bitmap32.BoundsRect, Bitmap32); TmpBitmap.DrawTo(Canvas.Handle, R, TmpBitmap.BoundsRect); TmpBitmap.Free; R.Left := R.Right; R.Right := ARect.Right; DefaultPropertyDrawValue(Self, Canvas, R); end; end; procedure TBitmap32Property.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); begin DefaultPropertyDrawName(Self, ACanvas, ARect); end; {$IFDEF COMPILER2005_UP} function TBitmap32Property.PropDrawNameRect(const ARect: TRect): TRect; begin Result := ARect; end; function TBitmap32Property.PropDrawValueRect(const ARect: TRect): TRect; begin if TBitmap32(GetOrdValue).Empty then Result := ARect else Result := Rect(ARect.Left, ARect.Top, (ARect.Bottom - ARect.Top) + ARect.Left, ARect.Bottom); end; {$ENDIF} {$ENDIF} procedure TBitmap32Property.SetValue(const Value: string); begin if Value = '' then SetOrdValue(0); end; { TImage32Editor } procedure TImage32Editor.ExecuteVerb(Index: Integer); var Img: TCustomImage32; BitmapEditor: TBitmap32Editor; begin Img := Component as TCustomImage32; if Index = 0 then begin BitmapEditor := TBitmap32Editor.Create(nil); try BitmapEditor.Bitmap32 := Img.Bitmap; if BitmapEditor.Execute then begin Img.Bitmap := BitmapEditor.Bitmap32; Designer.Modified; end; finally BitmapEditor.Free; end; end; end; function TImage32Editor.GetVerb(Index: Integer): string; begin if Index = 0 then Result := 'Bitmap32 Editor...'; end; function TImage32Editor.GetVerbCount: Integer; begin Result := 1; end; procedure TPictureEditorForm.AlphaChannelMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); var P: TPoint; begin if AlphaChannel.Bitmap <> nil then begin P := AlphaChannel.ControlToBitmap(Point(X, Y)); X := P.X; Y := P.Y; if (X >= 0) and (Y >= 0) and (X < AlphaChannel.Bitmap.Width) and (Y < AlphaChannel.Bitmap.Height) then Panel2.Caption := 'Alpha: $' + IntToHex(AlphaChannel.Bitmap[X, Y] and $FF, 2) + Format(' '#9'X: %d'#9'Y: %d', [X, Y]) else Panel2.Caption := ''; end else Panel2.Caption := ''; end; procedure TPictureEditorForm.RGBChannelsMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); var P: TPoint; begin if RGBChannels.Bitmap <> nil then begin P := RGBChannels.ControlToBitmap(Point(X, Y)); X := P.X; Y := P.Y; if (X >= 0) and (Y >= 0) and (X < RGBChannels.Bitmap.Width) and (Y < RGBChannels.Bitmap.Height) then Panel2.Caption := 'RGB: $' + IntToHex(RGBChannels.Bitmap[X, Y] and $00FFFFFF, 6) + Format(#9'X: %d'#9'Y: %d', [X, Y]) else Panel2.Caption := ''; end else Panel2.Caption := ''; end; end. |
Added src/graphics32/GR32_Dsgn_Color.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 | unit GR32_Dsgn_Color; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Classes, SysUtils, {$IFDEF FPC} RTLConsts, LazIDEIntf, PropEdits, Graphics, Dialogs, Forms, {$IFDEF Windows} Windows, Registry, {$ENDIF} {$ELSE} Consts, DesignIntf, DesignEditors, VCLEditors, Windows, Registry, Graphics, Dialogs, Forms, Controls, {$ENDIF} GR32, GR32_Image; type { TColorManager } PColorEntry = ^TColorEntry; TColorEntry = record Name: string[31]; Color: TColor32; end; TColorManager = class(TList) public destructor Destroy; override; procedure AddColor(const AName: string; AColor: TColor32); procedure EnumColors(Proc: TGetStrProc); function FindColor(const AName: string): TColor32; function GetColor(const AName: string): TColor32; function GetColorName(AColor: TColor32): string; procedure RegisterDefaultColors; procedure RemoveColor(const AName: string); end; {$IFDEF COMPILER2010_UP} TColor32Dialog = class(TCommonDialog) private FColor: TColor32; FCustomColors: TStrings; procedure SetCustomColors(Value: TStrings); public function Execute(ParentWnd: HWND): Boolean; override; published property Color: TColor32 read FColor write FColor default clBlack32; property CustomColors: TStrings read FCustomColors write SetCustomColors; property Ctl3D default True; end; {$ENDIF} { TColor32Property } TColor32Property = class(TIntegerProperty {$IFDEF EXT_PROP_EDIT} , ICustomPropertyListDrawing, ICustomPropertyDrawing {$IFDEF COMPILER2005_UP}, ICustomPropertyDrawing80{$ENDIF} {$ENDIF} ) public function GetAttributes: TPropertyAttributes; override; function GetValue: string; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const Value: string); override; {$IFDEF EXT_PROP_EDIT} procedure Edit; override; { ICustomPropertyListDrawing } procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas; var AWidth: Integer); procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas; var AHeight: Integer); procedure ListDrawValue(const Value: string; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); { ICustomPropertyDrawing } procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); {$IFDEF COMPILER2005_UP} { ICustomPropertyDrawing80 } function PropDrawNameRect(const ARect: TRect): TRect; function PropDrawValueRect(const ARect: TRect): TRect; {$ENDIF} {$ENDIF} end; procedure RegisterColor(const AName: string; AColor: TColor32); procedure UnregisterColor(const AName: string); var ColorManager: TColorManager; implementation {$IFDEF COMPILER2010_UP} uses GR32_Dsgn_ColorPicker; {$ENDIF} { TColorManager } destructor TColorManager.Destroy; var I: Integer; begin for I := 0 to Count - 1 do FreeMem(Items[I], SizeOf(TColorEntry)); inherited; end; procedure TColorManager.AddColor(const AName: string; AColor: TColor32); var NewEntry: PColorEntry; begin New(NewEntry); if NewEntry = nil then raise Exception.Create('Could not allocate memory for color registration!'); with NewEntry^ do begin Name := ShortString(AName); Color := AColor; end; Add(NewEntry); end; procedure TColorManager.EnumColors(Proc: TGetStrProc); var I: Integer; begin for I := 0 to Count - 1 do Proc(string(TColorEntry(Items[I]^).Name)); end; function TColorManager.FindColor(const AName: string): TColor32; var I: Integer; begin Result := clBlack32; for I := 0 to Count - 1 do with TColorEntry(Items[I]^) do if string(Name) = AName then begin Result := Color; Break; end; end; function TColorManager.GetColor(const AName: string): TColor32; var S: string; function HexToClr(const HexStr: string): Cardinal; var I: Integer; C: Char; begin Result := 0; for I := 1 to Length(HexStr) do begin C := HexStr[I]; case C of '0'..'9': Result := Int64(16) * Result + (Ord(C) - $30); 'A'..'F': Result := Int64(16) * Result + (Ord(C) - $37); 'a'..'f': Result := Int64(16) * Result + (Ord(C) - $57); else raise EConvertError.Create('Illegal character in hex string'); end; end; end; begin S := Trim(AName); if S[1] = '$' then S := Copy(S, 2, Length(S) - 1); if (S[1] = 'c') and (S[2] = 'l') then Result := FindColor(S) else try Result := HexToClr(S); except Result := clBlack32; end; end; function TColorManager.GetColorName(AColor: TColor32): string; var I: Integer; begin for I := 0 to Count - 1 do with TColorEntry(Items[I]^) do if Color = AColor then begin Result := string(TColorEntry(Items[I]^).Name); Exit; end; Result := '$' + IntToHex(AColor, 8); end; procedure TColorManager.RegisterDefaultColors; begin Capacity := 50; AddColor('clBlack32', clBlack32); AddColor('clDimGray32', clDimGray32); AddColor('clGray32', clGray32); AddColor('clLightGray32', clLightGray32); AddColor('clWhite32', clWhite32); AddColor('clMaroon32', clMaroon32); AddColor('clGreen32', clGreen32); AddColor('clOlive32', clOlive32); AddColor('clNavy32', clNavy32); AddColor('clPurple32', clPurple32); AddColor('clTeal32', clTeal32); AddColor('clRed32', clRed32); AddColor('clLime32', clLime32); AddColor('clYellow32', clYellow32); AddColor('clBlue32', clBlue32); AddColor('clFuchsia32', clFuchsia32); AddColor('clAqua32', clAqua32); AddColor('clTrWhite32', clTrWhite32); AddColor('clTrBlack32', clTrBlack32); AddColor('clTrRed32', clTrRed32); AddColor('clTrGreen32', clTrGreen32); AddColor('clTrBlue32', clTrBlue32); AddColor('clAliceBlue32', clAliceBlue32); AddColor('clAntiqueWhite32', clAntiqueWhite32); AddColor('clAquamarine32', clAquamarine32); AddColor('clAzure32', clAzure32); AddColor('clBeige32', clBeige32); AddColor('clBisque32', clBisque32); AddColor('clBlancheDalmond32', clBlancheDalmond32); AddColor('clBlueViolet32', clBlueViolet32); AddColor('clBrown32', clBrown32); AddColor('clBurlyWood32', clBurlyWood32); AddColor('clCadetblue32', clCadetblue32); AddColor('clChartReuse32', clChartReuse32); AddColor('clChocolate32', clChocolate32); AddColor('clCoral32', clCoral32); AddColor('clCornFlowerBlue32', clCornFlowerBlue32); AddColor('clCornSilk32', clCornSilk32); AddColor('clCrimson32', clCrimson32); AddColor('clDarkBlue32', clDarkBlue32); AddColor('clDarkCyan32', clDarkCyan32); AddColor('clDarkGoldenRod32', clDarkGoldenRod32); AddColor('clDarkGray32', clDarkGray32); AddColor('clDarkGreen32', clDarkGreen32); AddColor('clDarkGrey32', clDarkGrey32); AddColor('clDarkKhaki32', clDarkKhaki32); AddColor('clDarkMagenta32', clDarkMagenta32); AddColor('clDarkOliveGreen32', clDarkOliveGreen32); AddColor('clDarkOrange32', clDarkOrange32); AddColor('clDarkOrchid32', clDarkOrchid32); AddColor('clDarkRed32', clDarkRed32); AddColor('clDarkSalmon32', clDarkSalmon32); AddColor('clDarkSeaGreen32', clDarkSeaGreen32); AddColor('clDarkSlateBlue32', clDarkSlateBlue32); AddColor('clDarkSlateGray32', clDarkSlateGray32); AddColor('clDarkSlateGrey32', clDarkSlateGrey32); AddColor('clDarkTurquoise32', clDarkTurquoise32); AddColor('clDarkViolet32', clDarkViolet32); AddColor('clDeepPink32', clDeepPink32); AddColor('clDeepSkyBlue32', clDeepSkyBlue32); AddColor('clDodgerBlue32', clDodgerBlue32); AddColor('clFireBrick32', clFireBrick32); AddColor('clFloralWhite32', clFloralWhite32); AddColor('clGainsBoro32', clGainsBoro32); AddColor('clGhostWhite32', clGhostWhite32); AddColor('clGold32', clGold32); AddColor('clGoldenRod32', clGoldenRod32); AddColor('clGreenYellow32', clGreenYellow32); AddColor('clGrey32', clGrey32); AddColor('clHoneyDew32', clHoneyDew32); AddColor('clHotPink32', clHotPink32); AddColor('clIndianRed32', clIndianRed32); AddColor('clIndigo32', clIndigo32); AddColor('clIvory32', clIvory32); AddColor('clKhaki32', clKhaki32); AddColor('clLavender32', clLavender32); AddColor('clLavenderBlush32', clLavenderBlush32); AddColor('clLawnGreen32', clLawnGreen32); AddColor('clLemonChiffon32', clLemonChiffon32); AddColor('clLightBlue32', clLightBlue32); AddColor('clLightCoral32', clLightCoral32); AddColor('clLightCyan32', clLightCyan32); AddColor('clLightGoldenRodYellow32', clLightGoldenRodYellow32); AddColor('clLightGray32', clLightGray32); AddColor('clLightGreen32', clLightGreen32); AddColor('clLightGrey32', clLightGrey32); AddColor('clLightPink32', clLightPink32); AddColor('clLightSalmon32', clLightSalmon32); AddColor('clLightSeagreen32', clLightSeagreen32); AddColor('clLightSkyblue32', clLightSkyblue32); AddColor('clLightSlategray32', clLightSlategray32); AddColor('clLightSlategrey32', clLightSlategrey32); AddColor('clLightSteelblue32', clLightSteelblue32); AddColor('clLightYellow32', clLightYellow32); AddColor('clLtGray32', clLtGray32); AddColor('clMedGray32', clMedGray32); AddColor('clDkGray32', clDkGray32); AddColor('clMoneyGreen32', clMoneyGreen32); AddColor('clLegacySkyBlue32', clLegacySkyBlue32); AddColor('clCream32', clCream32); AddColor('clLimeGreen32', clLimeGreen32); AddColor('clLinen32', clLinen32); AddColor('clMediumAquamarine32', clMediumAquamarine32); AddColor('clMediumBlue32', clMediumBlue32); AddColor('clMediumOrchid32', clMediumOrchid32); AddColor('clMediumPurple32', clMediumPurple32); AddColor('clMediumSeaGreen32', clMediumSeaGreen32); AddColor('clMediumSlateBlue32', clMediumSlateBlue32); AddColor('clMediumSpringGreen32', clMediumSpringGreen32); AddColor('clMediumTurquoise32', clMediumTurquoise32); AddColor('clMediumVioletRed32', clMediumVioletRed32); AddColor('clMidnightBlue32', clMidnightBlue32); AddColor('clMintCream32', clMintCream32); AddColor('clMistyRose32', clMistyRose32); AddColor('clMoccasin32', clMoccasin32); AddColor('clNavajoWhite32', clNavajoWhite32); AddColor('clOldLace32', clOldLace32); AddColor('clOliveDrab32', clOliveDrab32); AddColor('clOrange32', clOrange32); AddColor('clOrangeRed32', clOrangeRed32); AddColor('clOrchid32', clOrchid32); AddColor('clPaleGoldenRod32', clPaleGoldenRod32); AddColor('clPaleGreen32', clPaleGreen32); AddColor('clPaleTurquoise32', clPaleTurquoise32); AddColor('clPaleVioletred32', clPaleVioletred32); AddColor('clPapayaWhip32', clPapayaWhip32); AddColor('clPeachPuff32', clPeachPuff32); AddColor('clPeru32', clPeru32); AddColor('clPlum32', clPlum32); AddColor('clPowderBlue32', clPowderBlue32); AddColor('clPurple32', clPurple32); AddColor('clRosyBrown32', clRosyBrown32); AddColor('clRoyalBlue32', clRoyalBlue32); AddColor('clSaddleBrown32', clSaddleBrown32); AddColor('clSalmon32', clSalmon32); AddColor('clSandyBrown32', clSandyBrown32); AddColor('clSeaGreen32', clSeaGreen32); AddColor('clSeaShell32', clSeaShell32); AddColor('clSienna32', clSienna32); AddColor('clSilver32', clSilver32); AddColor('clSkyblue32', clSkyblue32); AddColor('clSlateBlue32', clSlateBlue32); AddColor('clSlateGray32', clSlateGray32); AddColor('clSlateGrey32', clSlateGrey32); AddColor('clSnow32', clSnow32); AddColor('clSpringgreen32', clSpringgreen32); AddColor('clSteelblue32', clSteelblue32); AddColor('clTan32', clTan32); AddColor('clThistle32', clThistle32); AddColor('clTomato32', clTomato32); AddColor('clTurquoise32', clTurquoise32); AddColor('clViolet32', clViolet32); AddColor('clWheat32', clWheat32); AddColor('clWhitesmoke32', clWhitesmoke32); AddColor('clYellowgreen32', clYellowgreen32); end; procedure TColorManager.RemoveColor(const AName: string); var I: Integer; begin for I := 0 to Count - 1 do if CompareText(string(TColorEntry(Items[I]^).Name), AName) = 0 then begin Delete(I); Break; end; end; procedure RegisterColor(const AName: string; AColor: TColor32); begin ColorManager.AddColor(AName, AColor); end; procedure UnregisterColor(const AName: string); begin ColorManager.RemoveColor(AName); end; { TColor32Dialog } {$IFDEF COMPILER2010_UP} procedure TColor32Dialog.SetCustomColors(Value: TStrings); begin FCustomColors.Assign(Value); end; function TColor32Dialog.Execute(ParentWnd: HWND): Boolean; var ColorPicker: TFormColorPicker; begin ColorPicker := TFormColorPicker.Create(nil); try ColorPicker.Color := FColor; Result := ColorPicker.ShowModal = mrOK; if Result then FColor := ColorPicker.Color; finally ColorPicker.Free; end; end; {$ENDIF} { TColor32Property } {$IFDEF EXT_PROP_EDIT} procedure TColor32Property.Edit; var {$IFDEF COMPILER2010_UP} ColorDialog: TColor32Dialog; {$ELSE} ColorDialog: TColorDialog; {$ENDIF} IniFile: TRegIniFile; procedure GetCustomColors; begin if BaseRegistryKey = '' then Exit; IniFile := TRegIniFile.Create(BaseRegistryKey); try IniFile.ReadSectionValues(SCustomColors, ColorDialog.CustomColors); except { Ignore errors while reading values } end; end; procedure SaveCustomColors; var I, P: Integer; S: string; begin if IniFile <> nil then with ColorDialog do for I := 0 to CustomColors.Count - 1 do begin S := CustomColors.Strings[I]; P := Pos('=', S); if P <> 0 then begin S := Copy(S, 1, P - 1); IniFile.WriteString(SCustomColors, S, CustomColors.Values[S]); end; end; end; begin IniFile := nil; {$IFDEF COMPILER2010_UP} ColorDialog := TColor32Dialog.Create(Application); {$ELSE} ColorDialog := TColorDialog.Create(Application); {$ENDIF} try GetCustomColors; ColorDialog.Color := GetOrdValue; ColorDialog.HelpContext := 25010; {$IFNDEF COMPILER2010_UP} ColorDialog.Options := [cdShowHelp]; {$ENDIF} if ColorDialog.Execute then SetOrdValue(Cardinal(ColorDialog.Color)); SaveCustomColors; finally IniFile.Free; ColorDialog.Free; end; end; {$ENDIF} function TColor32Property.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, {$IFDEF EXT_PROP_EDIT}paDialog,{$ENDIF} paValueList, paRevertable]; end; procedure TColor32Property.GetValues(Proc: TGetStrProc); begin try ColorManager.EnumColors(Proc); except on E: Exception do ShowMessage(E.Message); end; end; function TColor32Property.GetValue: string; begin try Result := ColorManager.GetColorName(Cardinal(GetOrdValue)); except on E: Exception do ShowMessage(E.Message); end; end; procedure TColor32Property.SetValue(const Value: string); begin try SetOrdValue(Cardinal(ColorManager.GetColor(Value))); Modified; except on E: Exception do ShowMessage(E.Message); end; end; {$IFDEF EXT_PROP_EDIT} procedure TColor32Property.ListMeasureWidth(const Value: string; ACanvas: TCanvas; var AWidth: Integer); begin // implementation dummie to satisfy interface. Don't change default value. end; procedure TColor32Property.ListMeasureHeight(const Value: string; ACanvas: TCanvas; var AHeight: Integer); begin // implementation dummie to satisfy interface. Don't change default value. end; procedure TColor32Property.ListDrawValue(const Value: string; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); var Right: Integer; C: TColor32; i, j: Integer; W, H: Integer; Bitmap32: TBitmap32; begin try Right := (ARect.Bottom - ARect.Top) + ARect.Left; Bitmap32 := TBitmap32.Create; try W := Right - ARect.Left - 2; H := ARect.Bottom - ARect.Top - 2; Bitmap32.SetSize(W, H); if Assigned(ColorManager) then C := ColorManager.GetColor(Value) else C := clWhite32; if (W > 8) and (H > 8) then begin if not (C and $FF000000 = $FF000000) then begin for j := 0 to H - 1 do for i := 0 to W - 1 do if Odd(i div 3) = Odd(j div 3) then Bitmap32[i, j] := clBlack32 else Bitmap32[i, j] := clWhite32; end; Bitmap32.FillRectT(0, 0, W, H, C); end; Bitmap32.FrameRectTS(0, 0, W, H, $DF000000); Bitmap32.RaiseRectTS(1, 1, W - 1, H - 1, 20); Bitmap32.DrawTo(ACanvas.Handle, ARect.Left + 1, ARect.Top + 1); finally Bitmap32.Free; DefaultPropertyListDrawValue(Value, ACanvas, Rect(Right, ARect.Top, ARect.Right, ARect.Bottom), ASelected); end; except on E: Exception do ShowMessage(E.Message); end; end; procedure TColor32Property.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); begin if GetVisualValue <> '' then ListDrawValue(GetVisualValue, ACanvas, ARect, True{ASelected}) else DefaultPropertyDrawValue(Self, ACanvas, ARect); end; procedure TColor32Property.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); begin DefaultPropertyDrawName(Self, ACanvas, ARect); end; {$IFDEF COMPILER2005_UP} function TColor32Property.PropDrawNameRect(const ARect: TRect): TRect; begin Result := ARect; end; function TColor32Property.PropDrawValueRect(const ARect: TRect): TRect; begin Result := Rect(ARect.Left, ARect.Top, (ARect.Bottom - ARect.Top) + ARect.Left, ARect.Bottom); end; {$ENDIF} {$ENDIF} initialization ColorManager := TColorManager.Create; ColorManager.RegisterDefaultColors; finalization ColorManager.Free; end. |
Added src/graphics32/GR32_Dsgn_ColorPicker.dfm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 | object FormColorPicker: TFormColorPicker Left = 0 Top = 0 Caption = 'Color Picker' ClientHeight = 303 ClientWidth = 563 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'Tahoma' Font.Style = [] OldCreateOrder = False DesignSize = ( 563 303) PixelsPerInch = 96 TextHeight = 13 object LabelWebColor: TLabel Left = 432 Top = 178 Width = 23 Height = 13 Anchors = [akTop, akRight] Caption = 'Hex:' end object LabelRed: TLabel Left = 270 Top = 11 Width = 23 Height = 14 AutoSize = False Caption = 'Red:' end object LabelGreen: TLabel Left = 270 Top = 51 Width = 33 Height = 13 Caption = 'Green:' end object LabelBlue: TLabel Left = 270 Top = 91 Width = 19 Height = 14 AutoSize = False Caption = 'Blue:' end object LabelAlpha: TLabel Left = 270 Top = 131 Width = 31 Height = 13 Caption = 'Alpha:' end object LabelPreview: TLabel Left = 311 Top = 178 Width = 42 Height = 13 Caption = 'Preview:' end object LabelPalette: TLabel Left = 270 Top = 244 Width = 38 Height = 13 Caption = 'Palette:' Visible = False end object PanelControl: TPanel Left = 0 Top = 270 Width = 563 Height = 33 Align = alBottom BevelOuter = bvNone TabOrder = 0 DesignSize = ( 563 33) object ButtonOK: TButton Left = 411 Top = 6 Width = 64 Height = 23 Anchors = [akRight, akBottom] Caption = 'OK' Default = True ModalResult = 1 TabOrder = 0 end object ButtonCancel: TButton Left = 486 Top = 6 Width = 65 Height = 23 Anchors = [akRight, akBottom] Cancel = True Caption = '&Cancel' ModalResult = 2 TabOrder = 1 end object ButtonPickFromScreen: TButton Left = 8 Top = 5 Width = 105 Height = 23 Anchors = [akLeft, akBottom] Caption = 'Pick from screen' ModalResult = 1 TabOrder = 2 OnClick = ButtonPickFromScreenClick end object CheckBoxWebSafe: TCheckBox Left = 228 Top = 8 Width = 73 Height = 17 Caption = 'WebSafe' TabOrder = 3 OnClick = CheckBoxWebSafeClick end end object EditColor: TEdit Left = 474 Top = 175 Width = 81 Height = 21 Alignment = taCenter Anchors = [akTop, akRight] TabOrder = 1 Text = '$00000000' OnChange = EditColorChange end object ColorPickerGTK: TColorPickerGTK Left = 8 Top = 8 Width = 256 Height = 256 ParentBackground = False SelectedColor = -16777216 TabOrder = 2 OnChanged = ColorPickerChanged end object ColorPickerRed: TColorPickerComponent Left = 311 Top = 8 Width = 192 Height = 22 Anchors = [akTop, akRight] Border = True ColorComponent = ccRed ParentBackground = False SelectedColor = -16777216 TabOrder = 3 OnChanged = ColorPickerChanged end object ColorPickerGreen: TColorPickerComponent Left = 311 Top = 48 Width = 192 Height = 22 Anchors = [akTop, akRight] Border = True ColorComponent = ccGreen ParentBackground = False SelectedColor = -16777216 TabOrder = 4 OnChanged = ColorPickerChanged end object ColorPickerBlue: TColorPickerComponent Left = 311 Top = 88 Width = 192 Height = 22 Anchors = [akTop, akRight] Border = True ColorComponent = ccBlue ParentBackground = False SelectedColor = -16777216 TabOrder = 5 OnChanged = ColorPickerChanged end object ColorPickerAlpha: TColorPickerComponent Left = 311 Top = 128 Width = 192 Height = 22 Anchors = [akTop, akRight] Border = True ColorComponent = ccAlpha ParentBackground = False SelectedColor = -16777216 TabOrder = 6 OnChanged = ColorPickerChanged end object SpinEditRed: TSpinEdit Left = 509 Top = 8 Width = 46 Height = 22 Anchors = [akTop, akRight] MaxValue = 255 MinValue = 0 TabOrder = 7 Value = 0 OnChange = SpinEditColorChange end object SpinEditGreen: TSpinEdit Left = 509 Top = 48 Width = 46 Height = 22 Anchors = [akTop, akRight] MaxValue = 255 MinValue = 0 TabOrder = 8 Value = 0 OnChange = SpinEditColorChange end object SpinEditBlue: TSpinEdit Left = 509 Top = 88 Width = 46 Height = 22 Anchors = [akTop, akRight] MaxValue = 255 MinValue = 0 TabOrder = 9 Value = 0 OnChange = SpinEditColorChange end object SpinEditAlpha: TSpinEdit Left = 509 Top = 128 Width = 46 Height = 22 Anchors = [akTop, akRight] MaxValue = 255 MinValue = 0 TabOrder = 10 Value = 0 OnChange = SpinEditColorChange end object ColorSwatch: TColorSwatch Left = 359 Top = 164 Width = 33 Height = 32 Border = True Color = -360334 ParentBackground = False TabOrder = 11 end object ColorSwatchBlack: TColorSwatch Left = 321 Top = 238 Width = 24 Height = 24 Border = True Color = -16777216 ParentBackground = False TabOrder = 12 OnClick = ColorSwatchClick end object ColorSwatchWhite: TColorSwatch Left = 351 Top = 238 Width = 24 Height = 24 Border = True Color = -1 ParentBackground = False TabOrder = 13 OnClick = ColorSwatchClick end object ColorSwatchGreen: TColorSwatch Left = 411 Top = 238 Width = 24 Height = 24 Border = True Color = -16711936 ParentBackground = False TabOrder = 14 OnClick = ColorSwatchClick end object ColorSwatchRed: TColorSwatch Left = 381 Top = 238 Width = 24 Height = 24 Border = True Color = -65536 ParentBackground = False TabOrder = 15 OnClick = ColorSwatchClick end object ColorSwatchAqua: TColorSwatch Left = 531 Top = 238 Width = 24 Height = 24 Border = True Color = -16711681 ParentBackground = False TabOrder = 16 OnClick = ColorSwatchClick end object ColorSwatchFuchsia: TColorSwatch Left = 501 Top = 238 Width = 24 Height = 24 Border = True Color = -65281 ParentBackground = False TabOrder = 17 OnClick = ColorSwatchClick end object ColorSwatchYellow: TColorSwatch Left = 471 Top = 238 Width = 24 Height = 24 Border = True Color = -256 ParentBackground = False TabOrder = 18 OnClick = ColorSwatchClick end object ColorSwatchBlue: TColorSwatch Left = 441 Top = 238 Width = 24 Height = 24 Border = True Color = -16776961 ParentBackground = False TabOrder = 19 OnClick = ColorSwatchClick end end |
Added src/graphics32/GR32_Dsgn_ColorPicker.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | unit GR32_Dsgn_ColorPicker; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Christian-W. Budde * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Classes, SysUtils, {$IFDEF FPC} RTLConsts, LazIDEIntf, PropEdits, Graphics, Dialogs, Forms, Spin, ExtCtrls, StdCtrls, Controls, {$IFDEF Windows} Windows, Registry, {$ENDIF} {$ELSE} Consts, DesignIntf, DesignEditors, VCLEditors, StdCtrls, Controls, Windows, Registry, Graphics, Dialogs, Forms, ExtCtrls, Spin, {$ENDIF} GR32, GR32_ColorPicker, GR32_ColorSwatch; type TFormColorPicker = class(TForm) ButtonCancel: TButton; ButtonOK: TButton; ButtonPickFromScreen: TButton; CheckBoxWebSafe: TCheckBox; ColorPickerAlpha: TColorPickerComponent; ColorPickerBlue: TColorPickerComponent; ColorPickerGreen: TColorPickerComponent; ColorPickerGTK: TColorPickerGTK; ColorPickerRed: TColorPickerComponent; ColorSwatch: TColorSwatch; ColorSwatchAqua: TColorSwatch; ColorSwatchBlack: TColorSwatch; ColorSwatchBlue: TColorSwatch; ColorSwatchFuchsia: TColorSwatch; ColorSwatchGreen: TColorSwatch; ColorSwatchRed: TColorSwatch; ColorSwatchWhite: TColorSwatch; ColorSwatchYellow: TColorSwatch; EditColor: TEdit; LabelAlpha: TLabel; LabelBlue: TLabel; LabelGreen: TLabel; LabelPalette: TLabel; LabelPreview: TLabel; LabelRed: TLabel; LabelWebColor: TLabel; PanelControl: TPanel; SpinEditAlpha: TSpinEdit; SpinEditBlue: TSpinEdit; SpinEditGreen: TSpinEdit; SpinEditRed: TSpinEdit; procedure ButtonPickFromScreenClick(Sender: TObject); procedure ColorPickerChanged(Sender: TObject); procedure SpinEditColorChange(Sender: TObject); procedure CheckBoxWebSafeClick(Sender: TObject); procedure EditColorChange(Sender: TObject); procedure ColorSwatchClick(Sender: TObject); private FColor: TColor32; FScreenColorPickerForm: TScreenColorPickerForm; procedure UpdateColor; procedure ScreenColorPickerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure SetColor(const Value: TColor32); public property Color: TColor32 read FColor write SetColor; end; implementation {$R *.dfm} { TFormColorPicker } procedure TFormColorPicker.ButtonPickFromScreenClick(Sender: TObject); begin FScreenColorPickerForm := TScreenColorPickerForm.Create(Application); try FScreenColorPickerForm.OnMouseMove := ScreenColorPickerMouseMove; if FScreenColorPickerForm.ShowModal = mrOk then Color := FScreenColorPickerForm.SelectedColor; finally FreeAndNil(FScreenColorPickerForm); end; end; procedure TFormColorPicker.CheckBoxWebSafeClick(Sender: TObject); begin ColorPickerGTK.WebSafe := CheckBoxWebSafe.Checked; ColorPickerRed.WebSafe := CheckBoxWebSafe.Checked; ColorPickerGreen.WebSafe := CheckBoxWebSafe.Checked; ColorPickerBlue.WebSafe := CheckBoxWebSafe.Checked; ColorPickerAlpha.WebSafe := CheckBoxWebSafe.Checked; end; procedure TFormColorPicker.ColorPickerChanged(Sender: TObject); begin Color := TCustomColorPicker(Sender).SelectedColor; end; procedure TFormColorPicker.ColorSwatchClick(Sender: TObject); begin Color := TColorSwatch(Sender).Color; end; procedure TFormColorPicker.EditColorChange(Sender: TObject); var ColorText: string; Value: Integer; begin ColorText := StringReplace(EditColor.Text, '#', '$', []); if TryStrToInt(ColorText, Value) then Color := Value; end; procedure TFormColorPicker.ScreenColorPickerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin Color := FScreenColorPickerForm.SelectedColor; end; procedure TFormColorPicker.SetColor(const Value: TColor32); begin if FColor <> Value then begin FColor := Value; UpdateColor; end; end; procedure TFormColorPicker.SpinEditColorChange(Sender: TObject); begin EditColor.OnChange := nil; Color := SpinEditAlpha.Value shl 24 + SpinEditRed.Value shl 16 + SpinEditGreen.Value shl 8 + SpinEditBlue.Value; EditColor.OnChange := EditColorChange; end; procedure TFormColorPicker.UpdateColor; var R, G, B, A: Byte; SelStart: Integer; begin // disable OnChange handler EditColor.OnChange := nil; SpinEditRed.OnChange := nil; SpinEditGreen.OnChange := nil; SpinEditBlue.OnChange := nil; SpinEditAlpha.OnChange := nil; ColorPickerGTK.SelectedColor := FColor; ColorPickerRed.SelectedColor := FColor; ColorPickerGreen.SelectedColor := FColor; ColorPickerBlue.SelectedColor := FColor; ColorPickerAlpha.SelectedColor := FColor; ColorSwatch.Color := FColor; // update spin edits Color32ToRGBA(FColor, R, G, B, A); SpinEditRed.Value := R; SpinEditGreen.Value := G; SpinEditBlue.Value := B; SpinEditAlpha.Value := A; // update color edit SelStart := EditColor.SelStart; EditColor.Text := '#' + IntToHex(A, 2) + IntToHex(R, 2) + IntToHex(G, 2) + IntToHex(B, 2); EditColor.SelStart := SelStart; // re-enable OnChange handler SpinEditRed.OnChange := SpinEditColorChange; SpinEditGreen.OnChange := SpinEditColorChange; SpinEditBlue.OnChange := SpinEditColorChange; SpinEditAlpha.OnChange := SpinEditColorChange; EditColor.OnChange := EditColorChange; end; end. |
Added src/graphics32/GR32_Dsgn_Misc.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 | unit GR32_Dsgn_Misc; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developers of the Original Code are * Mattias Andersson <mattias@centaurix.com> * Andre Beckedorf <andre@metaexception.de> * * Portions created by the Initial Developer are Copyright (C) 2005-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LazIDEIntf, PropEdits,{$ELSE} Windows, DesignIntf, DesignEditors, ToolsAPI,{$ENDIF} Classes, TypInfo, GR32_Containers; type TCustomClassProperty = class(TClassProperty) private function HasSubProperties: Boolean; protected class function GetClassList: TClassList; virtual; procedure SetClassName(const CustomClass: string); virtual; {$IFNDEF BCB} abstract; {$ENDIF} function GetObject: TObject; virtual; {$IFNDEF BCB} abstract; {$ENDIF} public function GetAttributes: TPropertyAttributes; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const Value: string); override; function GetValue: string; override; end; TKernelClassProperty = class(TCustomClassProperty) protected class function GetClassList: TClassList; override; procedure SetClassName(const CustomClass: string); override; function GetObject: TObject; override; end; TResamplerClassProperty = class(TCustomClassProperty) protected class function GetClassList: TClassList; override; procedure SetClassName(const CustomClass: string); override; function GetObject: TObject; override; end; implementation uses GR32, GR32_Resamplers; {$IFDEF COMPILER2005_UP} var GSplashScreen : HBITMAP; {$ENDIF} { TCustomClassProperty } function TCustomClassProperty.GetAttributes: TPropertyAttributes; begin Result := inherited GetAttributes - [paReadOnly] + [paValueList, paRevertable, paVolatileSubProperties]; if not HasSubProperties then Exclude(Result, paSubProperties); end; class function TCustomClassProperty.GetClassList: TClassList; begin Result := nil; end; function TCustomClassProperty.GetValue: string; begin if PropCount > 0 then Result := GetObject.ClassName else Result := ''; end; procedure TCustomClassProperty.GetValues(Proc: TGetStrProc); var I: Integer; L: TClassList; begin L := GetClassList; if Assigned(L) then for I := 0 to L.Count - 1 do Proc(L.Items[I].ClassName); end; function TCustomClassProperty.HasSubProperties: Boolean; begin if PropCount > 0 then Result := GetTypeData(GetObject.ClassInfo)^.PropCount > 0 else Result := False; end; procedure TCustomClassProperty.SetValue(const Value: string); var L: TClassList; begin L := GetClassList; if Assigned(L) and Assigned(L.Find(Value)) then SetClassName(Value) else SetStrValue(''); Modified; end; {$IFDEF BCB} class function TCustomClassProperty.GetClassList: TClassList; begin Result := nil; end; procedure TCustomClassProperty.SetClassName(const CustomClass: string); begin end; function TCustomClassProperty.GetObject: TObject; begin Result := nil; end; {$ENDIF} { TKernelClassProperty } class function TKernelClassProperty.GetClassList: TClassList; begin Result := KernelList; end; function TKernelClassProperty.GetObject: TObject; begin Result := TKernelResampler(GetComponent(0)).Kernel; end; procedure TKernelClassProperty.SetClassName(const CustomClass: string); begin TKernelResampler(GetComponent(0)).KernelClassName := CustomClass; end; { TResamplerClassProperty } class function TResamplerClassProperty.GetClassList: TClassList; begin Result := ResamplerList; end; function TResamplerClassProperty.GetObject: TObject; begin Result := TBitmap32(GetComponent(0)).Resampler; end; procedure TResamplerClassProperty.SetClassName( const CustomClass: string); begin TBitmap32(GetComponent(0)).ResamplerClassName := CustomClass; end; initialization {$IFDEF COMPILER2005_UP} // Add Splash Screen GSplashScreen := LoadBitmap(hInstance, 'GR32'); (SplashScreenServices as IOTasplashScreenServices).AddPluginBitmap( 'GR32' + ' ' + Graphics32Version, GSplashScreen); {$ENDIF} end. |
Added src/graphics32/GR32_ExtImage.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 | unit GR32_ExtImage; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Extended Image components for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * * Portions created by the Initial Developer are Copyright (C) 2005-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LCLType, LMessages, {$ELSE} Windows, Messages, {$ENDIF} GR32, GR32_Image, GR32_Rasterizers, Classes, Controls; type TRenderThread = class; TRenderMode = (rnmFull, rnmConstrained); { TSyntheticImage32 } TSyntheticImage32 = class(TPaintBox32) private FRasterizer: TRasterizer; FAutoRasterize: Boolean; FDefaultProc: TWndMethod; FResized: Boolean; FRenderThread: TRenderThread; FOldAreaChanged: TAreaChangedEvent; FDstRect: TRect; FRenderMode: TRenderMode; FClearBuffer: Boolean; procedure SetRasterizer(const Value: TRasterizer); procedure StopRenderThread; procedure SetDstRect(const Value: TRect); procedure SetRenderMode(const Value: TRenderMode); protected procedure RasterizerChanged(Sender: TObject); procedure SetParent(AParent: TWinControl); override; {$IFDEF FPC} procedure FormWindowProc(var Message: TLMessage); {$ELSE} procedure FormWindowProc(var Message: TMessage); {$ENDIF} procedure DoRasterize; property RepaintMode; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Resize; override; procedure Rasterize; property DstRect: TRect read FDstRect write SetDstRect; published property AutoRasterize: Boolean read FAutoRasterize write FAutoRasterize; property Rasterizer: TRasterizer read FRasterizer write SetRasterizer; property Buffer; property Color; property ClearBuffer: Boolean read FClearBuffer write FClearBuffer; property RenderMode: TRenderMode read FRenderMode write SetRenderMode; end; { TRenderThread } TRenderThread = class(TThread) private FDest: TBitmap32; FRasterizer: TRasterizer; FOldAreaChanged: TAreaChangedEvent; FArea: TRect; FDstRect: TRect; procedure SynchronizedAreaChanged; procedure AreaChanged(Sender: TObject; const Area: TRect; const Hint: Cardinal); protected procedure Execute; override; procedure Rasterize; public constructor Create(Rasterizer: TRasterizer; Dst: TBitmap32; DstRect: TRect; Suspended: Boolean); end; procedure Rasterize(Rasterizer: TRasterizer; Dst: TBitmap32; DstRect: TRect); implementation uses Forms, SysUtils; procedure Rasterize(Rasterizer: TRasterizer; Dst: TBitmap32; DstRect: TRect); var R: TRenderThread; begin R := TRenderThread.Create(Rasterizer, Dst, DstRect, True); R.FreeOnTerminate := True; {$IFDEF USETHREADRESUME} R.Resume; {$ELSE} R.Start; {$ENDIF} end; { TSyntheticImage32 } constructor TSyntheticImage32.Create(AOwner: TComponent); begin inherited; FRasterizer := TRegularRasterizer.Create; FRasterizer.Sampler := Buffer.Resampler; FAutoRasterize := True; FResized := False; RepaintMode := rmDirect; RenderMode := rnmFull; BufferOversize := 0; end; destructor TSyntheticImage32.Destroy; var ParentForm: TCustomForm; begin StopRenderThread; if Assigned(FRenderThread) then FRenderThread.Free; if Assigned(FDefaultProc) then begin ParentForm := GetParentForm(Self); if ParentForm <> nil then ParentForm.WindowProc := FDefaultProc; end; FRasterizer.Free; inherited; end; procedure TSyntheticImage32.DoRasterize; begin if FAutoRasterize then Rasterize; end; {$IFDEF FPC} procedure TSyntheticImage32.FormWindowProc(var Message: TLMessage); var CmdType: Integer; begin FDefaultProc(Message); case Message.Msg of 534: FResized := False; 562: begin if FResized then DoRasterize; FResized := True; end; 274: begin CmdType := Message.WParam and $FFF0; if (CmdType = SC_MAXIMIZE) or (CmdType = SC_RESTORE) then DoRasterize; end; end; end; {$ELSE} procedure TSyntheticImage32.FormWindowProc(var Message: TMessage); var CmdType: Integer; begin FDefaultProc(Message); case Message.Msg of WM_MOVING: FResized := False; WM_EXITSIZEMOVE: begin if FResized then DoRasterize; FResized := True; end; WM_SYSCOMMAND: begin CmdType := Message.WParam and $FFF0; if (CmdType = SC_MAXIMIZE) or (CmdType = SC_RESTORE) then DoRasterize; end; end; end; {$ENDIF} procedure TSyntheticImage32.Rasterize; var R: TRect; begin { Clear buffer before rasterization } if FClearBuffer then begin Buffer.Clear(Color32(Color)); Invalidate; end; { Create rendering thread } StopRenderThread; FOldAreaChanged := Buffer.OnAreaChanged; if FRenderMode = rnmFull then R := Rect(0, 0, Buffer.Width, Buffer.Height) else R := FDstRect; FRenderThread := TRenderThread.Create(FRasterizer, Buffer, R, False); FResized := True; end; procedure TSyntheticImage32.RasterizerChanged(Sender: TObject); begin DoRasterize; end; procedure TSyntheticImage32.Resize; begin if not FResized then StopRenderThread; inherited; end; procedure TSyntheticImage32.SetDstRect(const Value: TRect); begin FDstRect := Value; end; procedure TSyntheticImage32.SetParent(AParent: TWinControl); var ParentForm: TCustomForm; begin ParentForm := GetParentForm(Self); if ParentForm = AParent then Exit; if ParentForm <> nil then if Assigned(FDefaultProc) then ParentForm.WindowProc := FDefaultProc; inherited; if AParent <> nil then begin ParentForm := GetParentForm(Self); if ParentForm <> nil then begin FDefaultProc := ParentForm.WindowProc; ParentForm.WindowProc := FormWindowProc; end; end; end; procedure TSyntheticImage32.SetRasterizer(const Value: TRasterizer); begin if Value <> FRasterizer then begin StopRenderThread; if Assigned(FRasterizer) then FRasterizer.Free; FRasterizer := Value; FRasterizer.OnChange := RasterizerChanged; DoRasterize; Changed; end; end; procedure TSyntheticImage32.SetRenderMode(const Value: TRenderMode); begin FRenderMode := Value; end; procedure TSyntheticImage32.StopRenderThread; begin if Assigned(FRenderThread) and (not FRenderThread.Terminated) then begin FRenderThread.Synchronize(FRenderThread.Terminate); FRenderThread.WaitFor; FreeAndNil(FRenderThread); end; end; { TRenderThread } constructor TRenderThread.Create(Rasterizer: TRasterizer; Dst: TBitmap32; DstRect: TRect; Suspended: Boolean); begin {$IFDEF USETHREADRESUME} inherited Create(True); {$ELSE} inherited Create(Suspended); {$ENDIF} FRasterizer := Rasterizer; FDest := Dst; FDstRect := DstRect; Priority := tpNormal; {$IFDEF USETHREADRESUME} if not Suspended then Resume; {$ENDIF} end; procedure TRenderThread.Execute; begin Rasterize; end; procedure TRenderThread.Rasterize; begin FRasterizer.Lock; { Save current AreaChanged handler } FOldAreaChanged := FDest.OnAreaChanged; FDest.OnAreaChanged := AreaChanged; try FRasterizer.Rasterize(FDest, FDstRect); except on EAbort do; end; { Reset old AreaChanged handler } FDest.OnAreaChanged := FOldAreaChanged; Synchronize(FRasterizer.Unlock); end; procedure TRenderThread.AreaChanged(Sender: TObject; const Area: TRect; const Hint: Cardinal); begin if Terminated then Abort else begin FArea := Area; Synchronize(SynchronizedAreaChanged); end; end; procedure TRenderThread.SynchronizedAreaChanged; begin if Assigned(FOldAreaChanged) then FOldAreaChanged(FDest, FArea, AREAINFO_RECT); end; end. |
Added src/graphics32/GR32_Filters.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 | unit GR32_Filters; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Michael Hansen <dyster_tid@hotmail.com> * - 2007/02/25 - Logical Mask Operations and related types * - 2007/02/27 - CopyComponents * - 2007/05/10 - Logical Mask Operation functions in pascal versions * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} {$IFDEF TARGET_X64} {$DEFINE PUREPASCAL} {$ENDIF} uses {$IFDEF FPC} {$ELSE} Windows, {$ENDIF} Classes, SysUtils, GR32; { Basic processing } type TLUT8 = array [Byte] of Byte; TLogicalOperator = (loXOR, loAND, loOR); procedure CopyComponents(Dst, Src: TCustomBitmap32; Components: TColor32Components);overload; procedure CopyComponents(Dst: TCustomBitmap32; DstX, DstY: Integer; Src: TCustomBitmap32; SrcRect: TRect; Components: TColor32Components); overload; procedure AlphaToGrayscale(Dst, Src: TCustomBitmap32); procedure ColorToGrayscale(Dst, Src: TCustomBitmap32; PreserveAlpha: Boolean = False); procedure IntensityToAlpha(Dst, Src: TCustomBitmap32); procedure Invert(Dst, Src: TCustomBitmap32; Components : TColor32Components = [ccAlpha, ccRed, ccGreen, ccBlue]); procedure InvertRGB(Dst, Src: TCustomBitmap32); procedure ApplyLUT(Dst, Src: TCustomBitmap32; const LUT: TLUT8; PreserveAlpha: Boolean = False); procedure ChromaKey(ABitmap: TCustomBitmap32; TrColor: TColor32); function CreateBitmask(Components: TColor32Components): TColor32; procedure ApplyBitmask(Dst: TCustomBitmap32; DstX, DstY: Integer; Src: TCustomBitmap32; SrcRect: TRect; Bitmask: TColor32; LogicalOperator: TLogicalOperator); overload; procedure ApplyBitmask(ABitmap: TCustomBitmap32; ARect: TRect; Bitmask: TColor32; LogicalOperator: TLogicalOperator); overload; procedure CheckParams(Dst, Src: TCustomBitmap32; ResizeDst: Boolean = True); implementation uses GR32_System, GR32_Bindings, GR32_Lowlevel; const SEmptyBitmap = 'The bitmap is nil'; SEmptySource = 'The source is nil'; SEmptyDestination = 'Destination is nil'; type { Function Prototypes } TLogicalMaskLine = procedure(Dst: PColor32; Mask: TColor32; Count: Integer); //Inplace TLogicalMaskLineEx = procedure(Src, Dst: PColor32; Count: Integer; Mask: TColor32); //"Src To Dst" {$HINTS OFF} var { masked logical operation functions } LogicalMaskLineXor: TLogicalMaskLine; LogicalMaskLineOr: TLogicalMaskLine; LogicalMaskLineAnd: TLogicalMaskLine; LogicalMaskLineXorEx: TLogicalMaskLineEx; LogicalMaskLineOrEx: TLogicalMaskLineEx; LogicalMaskLineAndEx: TLogicalMaskLineEx; {$HINTS ON} { Access to masked logical operation functions corresponding to a logical operation mode } const LOGICAL_MASK_LINE: array[TLogicalOperator] of ^TLogicalMaskLine = ( (@@LogicalMaskLineXor), (@@LogicalMaskLineAnd), (@@LogicalMaskLineOr) ); LOGICAL_MASK_LINE_EX: array[TLogicalOperator] of ^TLogicalMaskLineEx = ( (@@LogicalMaskLineXorEx), (@@LogicalMaskLineAndEx), (@@LogicalMaskLineOrEx) ); procedure CheckParams(Dst, Src: TCustomBitmap32; ResizeDst: Boolean = True); begin if not Assigned(Src) then raise Exception.Create(SEmptySource); if not Assigned(Dst) then raise Exception.Create(SEmptyDestination); if ResizeDst then Dst.SetSize(Src.Width, Src.Height); end; procedure CopyComponents(Dst, Src: TCustomBitmap32; Components: TColor32Components); begin if Components = [] then Exit; CheckParams(Dst, Src); CopyComponents(Dst, 0, 0, Src, Src.BoundsRect, Components); end; procedure CopyComponents(Dst: TCustomBitmap32; DstX, DstY: Integer; Src: TCustomBitmap32; SrcRect: TRect; Components: TColor32Components); var I, J, Count, ComponentCount, XOffset: Integer; Mask: TColor32; SrcRow, DstRow: PColor32Array; PBDst, PBSrc: PByteArray; DstRect: TRect; begin if Components = [] then Exit; CheckParams(Dst, Src, False); ComponentCount := 0; XOffset := 0; Mask := 0; if ccAlpha in Components then begin Inc(ComponentCount); Inc(Mask, $FF000000); XOffset := 3; end; if ccRed in Components then begin Inc(ComponentCount); Inc(Mask, $00FF0000); XOffset := 2; end; if ccGreen in Components then begin Inc(ComponentCount); Inc(Mask, $0000FF00); XOffset := 1; end; if ccBlue in Components then begin Inc(ComponentCount); Inc(Mask, $000000FF); end; with Dst do begin IntersectRect(SrcRect, SrcRect, Src.BoundsRect); if (SrcRect.Right < SrcRect.Left) or (SrcRect.Bottom < SrcRect.Top) then Exit; DstX := Clamp(DstX, 0, Width); DstY := Clamp(DstY, 0, Height); DstRect.TopLeft := GR32.Point(DstX, DstY); DstRect.Right := DstX + SrcRect.Right - SrcRect.Left; DstRect.Bottom := DstY + SrcRect.Bottom - SrcRect.Top; IntersectRect(DstRect, DstRect, BoundsRect); IntersectRect(DstRect, DstRect, ClipRect); if (DstRect.Right < DstRect.Left) or (DstRect.Bottom < DstRect.Top) then Exit; if not MeasuringMode then begin BeginUpdate; try with DstRect do if (Bottom - Top) > 0 then begin SrcRow := Pointer(Src.PixelPtr[SrcRect.Left, SrcRect.Top]); DstRow := Pointer(PixelPtr[Left, Top]); Count := Right - Left; if Count > 16 then case ComponentCount of 1://Byte ptr approach begin PBSrc := Pointer(SrcRow); Inc(PBSrc, XOffset); // shift the pointer to the given component of the first pixel PBDst := Pointer(DstRow); Inc(PBDst, XOffset); Count := Count * 4 - 64; Inc(PBSrc, Count); Inc(PBDst, Count); for I := 0 to Bottom - Top - 1 do begin //16x enrolled loop J := - Count; repeat PBDst[J] := PBSrc[J]; PBDst[J + 4] := PBSrc[J + 4]; PBDst[J + 8] := PBSrc[J + 8]; PBDst[J + 12] := PBSrc[J + 12]; PBDst[J + 16] := PBSrc[J + 16]; PBDst[J + 20] := PBSrc[J + 20]; PBDst[J + 24] := PBSrc[J + 24]; PBDst[J + 28] := PBSrc[J + 28]; PBDst[J + 32] := PBSrc[J + 32]; PBDst[J + 36] := PBSrc[J + 36]; PBDst[J + 40] := PBSrc[J + 40]; PBDst[J + 44] := PBSrc[J + 44]; PBDst[J + 48] := PBSrc[J + 48]; PBDst[J + 52] := PBSrc[J + 52]; PBDst[J + 56] := PBSrc[J + 56]; PBDst[J + 60] := PBSrc[J + 60]; Inc(J, 64) until J > 0; //The rest Dec(J, 64); while J < 0 do begin PBDst[J + 64] := PBSrc[J + 64]; Inc(J, 4); end; Inc(PBSrc, Src.Width * 4); Inc(PBDst, Width * 4); end; end; 2, 3: //Masked approach begin Count := Count - 8; Inc(DstRow, Count); Inc(SrcRow, Count); for I := 0 to Bottom - Top - 1 do begin //8x enrolled loop J := - Count; repeat Mask := not Mask; DstRow[J] := DstRow[J] and Mask; DstRow[J + 1] := DstRow[J + 1] and Mask; DstRow[J + 2] := DstRow[J + 2] and Mask; DstRow[J + 3] := DstRow[J + 3] and Mask; DstRow[J + 4] := DstRow[J + 4] and Mask; DstRow[J + 5] := DstRow[J + 5] and Mask; DstRow[J + 6] := DstRow[J + 6] and Mask; DstRow[J + 7] := DstRow[J + 7] and Mask; Mask := not Mask; DstRow[J] := DstRow[J] or SrcRow[J] and Mask; DstRow[J + 1] := DstRow[J + 1] or SrcRow[J + 1] and Mask; DstRow[J + 2] := DstRow[J + 2] or SrcRow[J + 2] and Mask; DstRow[J + 3] := DstRow[J + 3] or SrcRow[J + 3] and Mask; DstRow[J + 4] := DstRow[J + 4] or SrcRow[J + 4] and Mask; DstRow[J + 5] := DstRow[J + 5] or SrcRow[J + 5] and Mask; DstRow[J + 6] := DstRow[J + 6] or SrcRow[J + 6] and Mask; DstRow[J + 7] := DstRow[J + 7] or SrcRow[J + 7] and Mask; Inc(J, 8); until J > 0; //The rest Dec(J, 8); while J < 0 do begin DstRow[J + 8] := DstRow[J + 8] and not Mask or SrcRow[J + 8] and Mask; Inc(J); end; Inc(SrcRow, Src.Width); Inc(DstRow, Width); end; end; 4: //full copy approach approach, use MoveLongWord for I := 0 to Bottom - Top - 1 do begin MoveLongWord(SrcRow^, DstRow^, Count); Inc(SrcRow, Src.Width); Inc(DstRow, Width); end; end else begin for I := 0 to Bottom - Top - 1 do begin for J := 0 to Count - 1 do DstRow[J] := DstRow[J] and not Mask or SrcRow[J] and Mask; Inc(SrcRow, Src.Width); Inc(DstRow, Width); end; end; end; finally EndUpdate; end; end; Changed(DstRect); end; end; procedure AlphaToGrayscale(Dst, Src: TCustomBitmap32); var I: Integer; D, S : PColor32EntryArray; Alpha: Byte; begin CheckParams(Dst, Src); S := PColor32EntryArray(@Src.Bits[0]); D := PColor32EntryArray(@Dst.Bits[0]); for I := 0 to Src.Height * Src.Width -1 do begin Alpha := S[I].A; with D[I] do begin R := Alpha; G := Alpha; B := Alpha; end; end; Dst.Changed; end; procedure IntensityToAlpha(Dst, Src: TCustomBitmap32); var I: Integer; D, S : PColor32EntryArray; begin CheckParams(Dst, Src); S := PColor32EntryArray(@Src.Bits[0]); D := PColor32EntryArray(@Dst.Bits[0]); for I := 0 to Src.Width * Src.Height - 1 do D[I].A := (S[I].R * 61 + S[I].G * 174 + S[I].B * 21) shr 8; Dst.Changed; end; procedure Invert(Dst, Src: TCustomBitmap32; Components : TColor32Components = [ccAlpha, ccRed, ccGreen, ccBlue]); var Mask: TColor32; begin if Components = [] then Exit; Mask := CreateBitmask(Components); if Src = Dst then begin //Inplace CheckParams(Dst, Src, False); ApplyBitmask(Src, Src.BoundsRect, Mask, loXOR); end else begin //Src -> Dst CheckParams(Dst, Src); ApplyBitmask(Dst, 0, 0, Src, Src.BoundsRect, Mask, loXOR); end; end; procedure InvertRGB(Dst, Src: TCustomBitmap32); begin Invert(Src, Dst, [ccRed, ccGreen, ccBlue]); end; procedure ColorToGrayscale(Dst, Src: TCustomBitmap32; PreserveAlpha: Boolean = False); var I: Integer; D, S: PColor32; begin CheckParams(Dst, Src); D := @Dst.Bits[0]; S := @Src.Bits[0]; if PreserveAlpha then for I := 0 to Src.Width * Src.Height - 1 do begin D^ := Gray32(Intensity(S^), AlphaComponent(S^)); Inc(S); Inc(D); end else for I := 0 to Src.Width * Src.Height - 1 do begin D^ := Gray32(Intensity(S^)); Inc(S); Inc(D); end; Dst.Changed; end; procedure ApplyLUT(Dst, Src: TCustomBitmap32; const LUT: TLUT8; PreserveAlpha: Boolean = False); var I: Integer; D, S: PColor32Entry; begin CheckParams(Dst, Src); D := @Dst.Bits[0]; S := @Src.Bits[0]; if PreserveAlpha then for I := 0 to Src.Width * Src.Height - 1 do begin D.ARGB := D.ARGB and $FF000000 + LUT[S.B] + LUT[S.G] shl 8 + LUT[S.R] shl 16; Inc(S); Inc(D); end else for I := 0 to Src.Width * Src.Height - 1 do begin D.ARGB := $FF000000 + LUT[S.B] + LUT[S.G] shl 8 + LUT[S.R] shl 16; Inc(S); Inc(D); end; Dst.Changed; end; procedure ChromaKey(ABitmap: TCustomBitmap32; TrColor: TColor32); var P: PColor32; C: TColor32; I: Integer; begin TrColor := TrColor and $00FFFFFF; with ABitmap do begin P := PixelPtr[0, 0]; for I := 0 to Width * Height - 1 do begin C := P^ and $00FFFFFF; if C = TrColor then P^ := C; Inc(P) end; end; ABitmap.Changed; end; function CreateBitmask(Components: TColor32Components): TColor32; begin Result := 0; if ccAlpha in Components then Inc(Result, $FF000000); if ccRed in Components then Inc(Result, $00FF0000); if ccGreen in Components then Inc(Result, $0000FF00); if ccBlue in Components then Inc(Result, $000000FF); end; procedure ApplyBitmask(Dst: TCustomBitmap32; DstX, DstY: Integer; Src: TCustomBitmap32; SrcRect: TRect; Bitmask: TColor32; LogicalOperator: TLogicalOperator); var I, Count: Integer; DstRect: TRect; MaskProc : TLogicalMaskLineEx; begin CheckParams(Dst, Src, False); MaskProc := LOGICAL_MASK_LINE_EX[LogicalOperator]^; if Assigned(MaskProc) then with Dst do begin IntersectRect(SrcRect, SrcRect, Src.BoundsRect); if (SrcRect.Right < SrcRect.Left) or (SrcRect.Bottom < SrcRect.Top) then Exit; DstX := Clamp(DstX, 0, Width); DstY := Clamp(DstY, 0, Height); DstRect.TopLeft := GR32.Point(DstX, DstY); DstRect.Right := DstX + SrcRect.Right - SrcRect.Left; DstRect.Bottom := DstY + SrcRect.Bottom - SrcRect.Top; IntersectRect(DstRect, DstRect, Dst.BoundsRect); IntersectRect(DstRect, DstRect, Dst.ClipRect); if (DstRect.Right < DstRect.Left) or (DstRect.Bottom < DstRect.Top) then Exit; if not MeasuringMode then begin BeginUpdate; try with DstRect do if (Bottom - Top) > 0 then begin Count := Right - Left; if Count > 0 then for I := 0 to Bottom - Top - 1 do MaskProc(Src.PixelPtr[SrcRect.Left, SrcRect.Top + I], PixelPtr[Left, Top + I], Count, Bitmask) end; finally EndUpdate; end; end; Changed(DstRect); end; end; procedure ApplyBitmask(ABitmap: TCustomBitmap32; ARect: TRect; Bitmask: TColor32; LogicalOperator: TLogicalOperator); var I, Count: Integer; MaskProc : TLogicalMaskLine; begin if not Assigned(ABitmap) then raise Exception.Create(SEmptyBitmap); MaskProc := LOGICAL_MASK_LINE[LogicalOperator]^; if Assigned(MaskProc) then with ABitmap do begin IntersectRect(ARect, ARect, BoundsRect); IntersectRect(ARect, ARect, ClipRect); if (ARect.Right < ARect.Left) or (ARect.Bottom < ARect.Top) then Exit; if not MeasuringMode then begin BeginUpdate; try with ARect do if (Bottom - Top) > 0 then begin Count := Right - Left; if Count > 0 then begin if Count = Width then MaskProc(PixelPtr[Left, Top], Bitmask, Count * (Bottom - Top)) else for I := Top to Bottom - 1 do MaskProc(PixelPtr[Left, I], Bitmask, Count); end; end; finally EndUpdate; end; end; Changed(ARect); end; end; { In-place logical mask functions } { Non - MMX versions} procedure XorLine_Pas(Dst: PColor32; Mask: TColor32; Count: Integer); var DstRow: PColor32Array absolute Dst; begin Inc(Dst, Count); Count := - Count; repeat DstRow[Count] := DstRow[Count] xor Mask; Inc(Count); until Count = 0; end; procedure OrLine_Pas(Dst: PColor32; Mask: TColor32; Count: Integer); var DstRow: PColor32Array absolute Dst; begin Inc(Dst, Count); Count := - Count; repeat DstRow[Count] := DstRow[Count] or Mask; Inc(Count); until Count = 0; end; procedure AndLine_Pas(Dst: PColor32; Mask: TColor32; Count: Integer); var DstRow: PColor32Array absolute Dst; begin Inc(Dst, Count); Count := - Count; repeat DstRow[Count] := DstRow[Count] and Mask; Inc(Count); until Count = 0; end; {$IFNDEF PUREPASCAL} procedure XorLine_ASM(Dst: PColor32; Mask: TColor32; Count: Integer); // No speedup achieveable using MMX asm {$IFDEF TARGET_x86} TEST ECX, ECX JZ @Exit PUSH EBX MOV EBX, ECX SHR ECX, 4 SHL ECX, 4 JZ @PrepSingleLoop LEA EAX, [EAX + ECX * 4] SHL ECX, 2 NEG ECX @ChunkLoop: //16x unrolled loop XOR [EAX + ECX], EDX XOR [EAX + ECX + 4], EDX XOR [EAX + ECX + 8], EDX XOR [EAX + ECX + 12], EDX XOR [EAX + ECX + 16], EDX XOR [EAX + ECX + 20], EDX XOR [EAX + ECX + 24], EDX XOR [EAX + ECX + 28], EDX XOR [EAX + ECX + 32], EDX XOR [EAX + ECX + 36], EDX XOR [EAX + ECX + 40], EDX XOR [EAX + ECX + 44], EDX XOR [EAX + ECX + 48], EDX XOR [EAX + ECX + 52], EDX XOR [EAX + ECX + 56], EDX XOR [EAX + ECX + 60], EDX ADD ECX, 16 * 4 JNZ @ChunkLoop @PrepSingleLoop: MOV ECX, EBX SHR EBX, 4 SHL EBX, 4 SUB ECX, EBX JZ @PopExit LEA EAX, [EAX + ECX * 4] NEG ECX @SingleLoop: XOR [EAX + ECX * 4], EDX INC ECX JNZ @SingleLoop @PopExit: POP EBX @Exit: {$ENDIF} {$IFDEF TARGET_x64} TEST R8D, R8D JZ @Exit MOV EAX, R8D SHR R8D, 4 SHL R8D, 4 JZ @PrepSingleLoop LEA RCX, [RCX + R8D * 4] SHL R8D, 2 NEG R8D @ChunkLoop: //16x unrolled loop XOR [RCX + R8D], EDX XOR [RCX + R8D + 4], EDX XOR [RCX + R8D + 8], EDX XOR [RCX + R8D + 12], EDX XOR [RCX + R8D + 16], EDX XOR [RCX + R8D + 20], EDX XOR [RCX + R8D + 24], EDX XOR [RCX + R8D + 28], EDX XOR [RCX + R8D + 32], EDX XOR [RCX + R8D + 36], EDX XOR [RCX + R8D + 40], EDX XOR [RCX + R8D + 44], EDX XOR [RCX + R8D + 48], EDX XOR [RCX + R8D + 52], EDX XOR [RCX + R8D + 56], EDX XOR [RCX + R8D + 60], EDX ADD R8D, 16 * 4 JNZ @ChunkLoop @PrepSingleLoop: MOV R8D, EAX SHR EAX, 4 SHL EAX, 4 SUB R8D, EAX JZ @Exit LEA RCX, [RCX + R8D * 4] NEG R8D @SingleLoop: XOR [RCX + R8D * 4], EDX INC R8D JNZ @SingleLoop @Exit: {$ENDIF} end; procedure OrLine_ASM(Dst: PColor32; Mask: TColor32; Count: Integer); // No speedup achieveable using MMX asm {$IFDEF TARGET_x86} TEST ECX, ECX JZ @Exit PUSH EBX MOV EBX, ECX SHR ECX, 4 SHL ECX, 4 JZ @PrepSingleLoop LEA EAX, [EAX + ECX * 4] SHL ECX, 2 NEG ECX @ChunkLoop: //16x unrolled loop OR [EAX + ECX], EDX OR [EAX + ECX + 4], EDX OR [EAX + ECX + 8], EDX OR [EAX + ECX + 12], EDX OR [EAX + ECX + 16], EDX OR [EAX + ECX + 20], EDX OR [EAX + ECX + 24], EDX OR [EAX + ECX + 28], EDX OR [EAX + ECX + 32], EDX OR [EAX + ECX + 36], EDX OR [EAX + ECX + 40], EDX OR [EAX + ECX + 44], EDX OR [EAX + ECX + 48], EDX OR [EAX + ECX + 52], EDX OR [EAX + ECX + 56], EDX OR [EAX + ECX + 60], EDX ADD ECX, 16 * 4 JNZ @ChunkLoop @PrepSingleLoop: MOV ECX, EBX SHR EBX, 4 SHL EBX, 4 SUB ECX, EBX JZ @PopExit LEA EAX, [EAX + ECX * 4] NEG ECX @SingleLoop: OR [EAX + ECX * 4], EDX INC ECX JNZ @SingleLoop @PopExit: POP EBX @Exit: {$ENDIF} {$IFDEF TARGET_x64} TEST R8D, R8D JZ @Exit MOV EAX, R8D SHR R8D, 4 SHL R8D, 4 JZ @PrepSingleLoop LEA RCX, [RCX + R8D * 4] SHL R8D, 2 NEG R8D @ChunkLoop: //16x unrolled loop OR [RCX + R8D], EDX OR [RCX + R8D + 4], EDX OR [RCX + R8D + 8], EDX OR [RCX + R8D + 12], EDX OR [RCX + R8D + 16], EDX OR [RCX + R8D + 20], EDX OR [RCX + R8D + 24], EDX OR [RCX + R8D + 28], EDX OR [RCX + R8D + 32], EDX OR [RCX + R8D + 36], EDX OR [RCX + R8D + 40], EDX OR [RCX + R8D + 44], EDX OR [RCX + R8D + 48], EDX OR [RCX + R8D + 52], EDX OR [RCX + R8D + 56], EDX OR [RCX + R8D + 60], EDX ADD R8D, 16 * 4 JNZ @ChunkLoop @PrepSingleLoop: MOV R8D, EAX SHR EAX, 4 SHL EAX, 4 SUB R8D, EAX JZ @Exit LEA RCX, [RCX + R8D * 4] NEG R8D @SingleLoop: OR [RCX + R8D * 4], EDX INC R8D JNZ @SingleLoop @Exit: {$ENDIF} end; procedure AndLine_ASM(Dst: PColor32; Mask: TColor32; Count: Integer); // No speedup achieveable using MMX asm {$IFDEF TARGET_x86} TEST ECX, ECX JZ @Exit PUSH EBX MOV EBX, ECX SHR ECX, 4 SHL ECX, 4 JZ @PrepSingleLoop LEA EAX, [EAX + ECX * 4] SHL ECX, 2 NEG ECX @ChunkLoop: //16x unrolled loop AND [EAX + ECX], EDX AND [EAX + ECX + 4], EDX AND [EAX + ECX + 8], EDX AND [EAX + ECX + 12], EDX AND [EAX + ECX + 16], EDX AND [EAX + ECX + 20], EDX AND [EAX + ECX + 24], EDX AND [EAX + ECX + 28], EDX AND [EAX + ECX + 32], EDX AND [EAX + ECX + 36], EDX AND [EAX + ECX + 40], EDX AND [EAX + ECX + 44], EDX AND [EAX + ECX + 48], EDX AND [EAX + ECX + 52], EDX AND [EAX + ECX + 56], EDX AND [EAX + ECX + 60], EDX ADD ECX, 16 * 4 JNZ @ChunkLoop @PrepSingleLoop: MOV ECX, EBX SHR EBX, 4 SHL EBX, 4 SUB ECX, EBX JZ @PopExit LEA EAX, [EAX + ECX * 4] NEG ECX @SingleLoop: AND [EAX + ECX * 4], EDX INC ECX JNZ @SingleLoop @PopExit: POP EBX @Exit: {$ENDIF} {$IFDEF TARGET_x64} TEST R8D, R8D JZ @Exit MOV EAX, R8D SHR R8D, 4 SHL R8D, 4 JZ @PrepSingleLoop LEA RCX, [RCX + R8D * 4] SHL R8D, 2 NEG R8D @ChunkLoop: //16x unrolled loop AND [RCX + R8D], EDX AND [RCX + R8D + 4], EDX AND [RCX + R8D + 8], EDX AND [RCX + R8D + 12], EDX AND [RCX + R8D + 16], EDX AND [RCX + R8D + 20], EDX AND [RCX + R8D + 24], EDX AND [RCX + R8D + 28], EDX AND [RCX + R8D + 32], EDX AND [RCX + R8D + 36], EDX AND [RCX + R8D + 40], EDX AND [RCX + R8D + 44], EDX AND [RCX + R8D + 48], EDX AND [RCX + R8D + 52], EDX AND [RCX + R8D + 56], EDX AND [RCX + R8D + 60], EDX ADD R8D, 16 * 4 JNZ @ChunkLoop @PrepSingleLoop: MOV R8D, EAX SHR EAX, 4 SHL EAX, 4 SUB R8D, EAX JZ @Exit LEA RCX, [RCX + R8D * 4] NEG R8D @SingleLoop: AND [RCX + R8D * 4], EDX INC R8D JNZ @SingleLoop @Exit: {$ENDIF} end; {$ENDIF} { extended logical mask functions Src -> Dst } { Non - MMX versions} procedure XorLineEx_Pas(Src, Dst: PColor32; Count: Integer; Mask: TColor32); var SrcRow: PColor32Array absolute Src; DstRow: PColor32Array absolute Dst; begin Inc(Dst, Count); Inc(Src, Count); Count := - Count; repeat DstRow[Count] := SrcRow[Count] xor Mask; Inc(Count); until Count = 0; end; procedure OrLineEx_Pas(Src, Dst: PColor32; Count: Integer; Mask: TColor32); var SrcRow: PColor32Array absolute Src; DstRow: PColor32Array absolute Dst; begin Inc(Dst, Count); Inc(Src, Count); Count := - Count; repeat DstRow[Count] := SrcRow[Count] or Mask; Inc(Count); until Count = 0; end; procedure AndLineEx_Pas(Src, Dst: PColor32; Count: Integer; Mask: TColor32); var SrcRow: PColor32Array absolute Src; DstRow: PColor32Array absolute Dst; begin Inc(Dst, Count); Inc(Src, Count); Count := - Count; repeat DstRow[Count] := SrcRow[Count] and Mask; Inc(Count); until Count = 0; end; {$IFNDEF PUREPASCAL} procedure XorLineEx_ASM(Src, Dst: PColor32; Count: Integer; Mask: TColor32); asm {$IFDEF TARGET_x86} PUSH EBX PUSH EDI LEA EAX, [EAX + ECX * 4] LEA EDX, [EDX + ECX * 4] NEG ECX JZ @Exit MOV EDI, Mask @Loop: MOV EBX, [EAX + ECX * 4] XOR EBX, EDI MOV [EDX + ECX * 4], EBX INC ECX JNZ @Loop @Exit: POP EDI POP EBX {$ENDIF} {$IFDEF TARGET_x64} LEA RCX, [RCX + R8D * 4] LEA RDX, [RDX + R8D * 4] NEG R8D JZ @Exit @Loop: MOV EAX, [RCX + R8D * 4] XOR EAX, R9D MOV [RDX + R8D * 4], EAX INC R8D JNZ @Loop @Exit: {$ENDIF} end; procedure OrLineEx_ASM(Src, Dst: PColor32; Count: Integer; Mask: TColor32); asm {$IFDEF TARGET_x86} PUSH EBX PUSH EDI LEA EAX, [EAX + ECX * 4] LEA EDX, [EDX + ECX * 4] NEG ECX JZ @Exit MOV EDI, Mask @Loop: MOV EBX, [EAX + ECX * 4] OR EBX, EDI MOV [EDX + ECX * 4], EBX INC ECX JNZ @Loop @Exit: POP EDI POP EBX {$ENDIF} {$IFDEF TARGET_x64} LEA RCX, [RCX + R8D * 4] LEA RDX, [RDX + R8D * 4] NEG R8D JZ @Exit @Loop: MOV EBX, [RCX + R8D * 4] OR EBX, R9D MOV [RDX + R8D * 4], EBX INC R8D JNZ @Loop @Exit: {$ENDIF} end; procedure AndLineEx_ASM(Src, Dst: PColor32; Count: Integer; Mask: TColor32); asm {$IFDEF TARGET_x86} PUSH EBX PUSH EDI LEA EAX, [EAX + ECX * 4] LEA EDX, [EDX + ECX * 4] NEG ECX JZ @Exit MOV EDI, Mask @Loop: MOV EBX, [EAX + ECX * 4] AND EBX, EDI MOV [EDX + ECX * 4], EBX INC ECX JNZ @Loop @Exit: POP EDI POP EBX {$ENDIF} {$IFDEF TARGET_x64} LEA RCX, [RCX + R8D * 4] LEA RDX, [RDX + R8D * 4] NEG R8D JZ @Exit @Loop: MOV EAX, [RCX + R8D * 4] AND EAX, R9D MOV [RDX + R8D * 4], EAX INC R8D JNZ @Loop @Exit: {$ENDIF} end; { MMX versions} {$IFNDEF OMIT_MMX} procedure XorLineEx_MMX(Src, Dst: PColor32; Count: Integer; Mask: TColor32); //MMX version var QMask: Int64; asm PUSH EBX PUSH EDI TEST ECX, ECX JZ @Exit MOV EBX, ECX SHR ECX, 4 SHL ECX, 4 JZ @PrepSingleLoop SAR ECX, 1 LEA EAX, [EAX + ECX * 8] LEA EDX, [EDX + ECX * 8] NEG ECX MOVD MM7, MASK PUNPCKLDQ MM7, MM7 MOVQ QMask, MM7 EMMS @Loop: MOVQ MM0, [EAX + ECX * 8] MOVQ MM1, [EAX + ECX * 8 + 8] MOVQ MM2, [EAX + ECX * 8 + 16] MOVQ MM3, [EAX + ECX * 8 + 24] MOVQ MM4, [EAX + ECX * 8 + 32] MOVQ MM5, [EAX + ECX * 8 + 40] MOVQ MM6, [EAX + ECX * 8 + 48] MOVQ MM7, [EAX + ECX * 8 + 56] PXOR MM0, QMask PXOR MM1, QMask PXOR MM2, QMask PXOR MM3, QMask PXOR MM4, QMask PXOR MM5, QMask PXOR MM6, QMask PXOR MM7, QMask MOVQ [EDX + ECX * 8], MM0 MOVQ [EDX + ECX * 8 + 8], MM1 MOVQ [EDX + ECX * 8 + 16], MM2 MOVQ [EDX + ECX * 8 + 24], MM3 MOVQ [EDX + ECX * 8 + 32], MM4 MOVQ [EDX + ECX * 8 + 40], MM5 MOVQ [EDX + ECX * 8 + 48], MM6 MOVQ [EDX + ECX * 8 + 56], MM7 ADD ECX, 8 JS @Loop EMMS @PrepSingleLoop: MOV ECX, EBX SHR EBX, 4 SHL EBX, 4 SUB ECX, EBX JZ @Exit LEA EAX, [EAX + ECX * 4] LEA EDX, [EDX + ECX * 4] NEG ECX MOV EDI, Mask @SingleLoop: MOV EBX, [EAX + ECX * 4] XOR EBX, EDI MOV [EDX + ECX * 4], EBX INC ECX JNZ @SingleLoop @Exit: POP EDI POP EBX end; procedure OrLineEx_MMX(Src, Dst: PColor32; Count: Integer; Mask: TColor32); //MMX version var QMask: Int64; asm PUSH EBX PUSH EDI TEST ECX, ECX JZ @Exit MOV EBX, ECX SHR ECX, 4 SHL ECX, 4 JZ @PrepSingleLoop SAR ECX, 1 LEA EAX, [EAX + ECX * 8] LEA EDX, [EDX + ECX * 8] NEG ECX MOVD MM7, MASK PUNPCKLDQ MM7, MM7 MOVQ QMask, MM7 EMMS @Loop: MOVQ MM0, [EAX + ECX * 8] MOVQ MM1, [EAX + ECX * 8 + 8] MOVQ MM2, [EAX + ECX * 8 + 16] MOVQ MM3, [EAX + ECX * 8 + 24] MOVQ MM4, [EAX + ECX * 8 + 32] MOVQ MM5, [EAX + ECX * 8 + 40] MOVQ MM6, [EAX + ECX * 8 + 48] MOVQ MM7, [EAX + ECX * 8 + 56] POR MM0, QMask POR MM1, QMask POR MM2, QMask POR MM3, QMask POR MM4, QMask POR MM5, QMask POR MM6, QMask POR MM7, QMask MOVQ [EDX + ECX * 8], MM0 MOVQ [EDX + ECX * 8 + 8], MM1 MOVQ [EDX + ECX * 8 + 16], MM2 MOVQ [EDX + ECX * 8 + 24], MM3 MOVQ [EDX + ECX * 8 + 32], MM4 MOVQ [EDX + ECX * 8 + 40], MM5 MOVQ [EDX + ECX * 8 + 48], MM6 MOVQ [EDX + ECX * 8 + 56], MM7 ADD ECX, 8 JS @Loop EMMS @PrepSingleLoop: MOV ECX, EBX SHR EBX, 4 SHL EBX, 4 SUB ECX, EBX JZ @Exit LEA EAX, [EAX + ECX * 4] LEA EDX, [EDX + ECX * 4] NEG ECX MOV EDI, Mask @SingleLoop: MOV EBX, [EAX + ECX * 4] OR EBX, EDI MOV [EDX + ECX * 4], EBX INC ECX JNZ @SingleLoop @Exit: POP EDI POP EBX end; procedure AndLineEx_MMX(Src, Dst: PColor32; Count: Integer; Mask: TColor32); //MMX version var QMask: Int64; asm PUSH EBX PUSH EDI TEST ECX, ECX JZ @Exit MOV EBX, ECX SHR ECX, 4 SHL ECX, 4 JZ @PrepSingleLoop SAR ECX, 1 LEA EAX, [EAX + ECX * 8] LEA EDX, [EDX + ECX * 8] NEG ECX MOVD MM7, MASK PUNPCKLDQ MM7, MM7 MOVQ QMask, MM7 EMMS @Loop: MOVQ MM0, [EAX + ECX * 8] MOVQ MM1, [EAX + ECX * 8 + 8] MOVQ MM2, [EAX + ECX * 8 + 16] MOVQ MM3, [EAX + ECX * 8 + 24] MOVQ MM4, [EAX + ECX * 8 + 32] MOVQ MM5, [EAX + ECX * 8 + 40] MOVQ MM6, [EAX + ECX * 8 + 48] MOVQ MM7, [EAX + ECX * 8 + 56] PAND MM0, QMask PAND MM1, QMask PAND MM2, QMask PAND MM3, QMask PAND MM4, QMask PAND MM5, QMask PAND MM6, QMask PAND MM7, QMask MOVQ [EDX + ECX * 8], MM0 MOVQ [EDX + ECX * 8 + 8], MM1 MOVQ [EDX + ECX * 8 + 16], MM2 MOVQ [EDX + ECX * 8 + 24], MM3 MOVQ [EDX + ECX * 8 + 32], MM4 MOVQ [EDX + ECX * 8 + 40], MM5 MOVQ [EDX + ECX * 8 + 48], MM6 MOVQ [EDX + ECX * 8 + 56], MM7 ADD ECX, 8 JS @Loop EMMS @PrepSingleLoop: MOV ECX, EBX SHR EBX, 4 SHL EBX, 4 SUB ECX, EBX JZ @Exit LEA EAX, [EAX + ECX * 4] LEA EDX, [EDX + ECX * 4] NEG ECX MOV EDI, Mask @SingleLoop: MOV EBX, [EAX + ECX * 4] AND EBX, EDI MOV [EDX + ECX * 4], EBX INC ECX JNZ @SingleLoop @Exit: POP EDI POP EBX end; { Extended MMX versions} procedure XorLineEx_EMMX(Src, Dst: PColor32; Count: Integer; Mask: TColor32); //EMMX version var QMask: Int64; asm PUSH EBX PUSH EDI TEST ECX, ECX JZ @Exit MOV EBX, ECX SHR ECX, 4 SHL ECX, 4 JZ @PrepSingleLoop SAR ECX, 1 LEA EAX, [EAX + ECX * 8] LEA EDX, [EDX + ECX * 8] NEG ECX MOVD MM7, MASK PUNPCKLDQ MM7, MM7 MOVQ QMask, MM7 EMMS @Loop: MOVQ MM0, [EAX + ECX * 8] MOVQ MM1, [EAX + ECX * 8 + 8] MOVQ MM2, [EAX + ECX * 8 + 16] MOVQ MM3, [EAX + ECX * 8 + 24] MOVQ MM4, [EAX + ECX * 8 + 32] MOVQ MM5, [EAX + ECX * 8 + 40] MOVQ MM6, [EAX + ECX * 8 + 48] MOVQ MM7, [EAX + ECX * 8 + 56] PXOR MM0, QMask PXOR MM1, QMask PXOR MM2, QMask PXOR MM3, QMask PXOR MM4, QMask PXOR MM5, QMask PXOR MM6, QMask PXOR MM7, QMask MOVNTQ [EDX + ECX * 8], MM0 MOVNTQ [EDX + ECX * 8 + 8], MM1 MOVNTQ [EDX + ECX * 8 + 16], MM2 MOVNTQ [EDX + ECX * 8 + 24], MM3 MOVNTQ [EDX + ECX * 8 + 32], MM4 MOVNTQ [EDX + ECX * 8 + 40], MM5 MOVNTQ [EDX + ECX * 8 + 48], MM6 MOVNTQ [EDX + ECX * 8 + 56], MM7 ADD ECX, 8 JS @Loop EMMS @PrepSingleLoop: MOV ECX, EBX SHR EBX, 4 SHL EBX, 4 SUB ECX, EBX JZ @Exit LEA EAX, [EAX + ECX * 4] LEA EDX, [EDX + ECX * 4] NEG ECX MOV EDI, Mask @SingleLoop: MOV EBX, [EAX + ECX * 4] XOR EBX, EDI MOV [EDX + ECX * 4], EBX INC ECX JNZ @SingleLoop @Exit: POP EDI POP EBX end; procedure OrLineEx_EMMX(Src, Dst: PColor32; Count: Integer; Mask: TColor32); //EMMX version var QMask: Int64; asm PUSH EBX PUSH EDI TEST ECX, ECX JZ @Exit MOV EBX, ECX SHR ECX, 4 SHL ECX, 4 JZ @PrepSingleLoop SAR ECX, 1 LEA EAX, [EAX + ECX * 8] LEA EDX, [EDX + ECX * 8] NEG ECX MOVD MM7, MASK PUNPCKLDQ MM7, MM7 MOVQ QMask, MM7 EMMS @Loop: MOVQ MM0, [EAX + ECX * 8] MOVQ MM1, [EAX + ECX * 8 + 8] MOVQ MM2, [EAX + ECX * 8 + 16] MOVQ MM3, [EAX + ECX * 8 + 24] MOVQ MM4, [EAX + ECX * 8 + 32] MOVQ MM5, [EAX + ECX * 8 + 40] MOVQ MM6, [EAX + ECX * 8 + 48] MOVQ MM7, [EAX + ECX * 8 + 56] POR MM0, QMask POR MM1, QMask POR MM2, QMask POR MM3, QMask POR MM4, QMask POR MM5, QMask POR MM6, QMask POR MM7, QMask MOVNTQ [EDX + ECX * 8], MM0 MOVNTQ [EDX + ECX * 8 + 8], MM1 MOVNTQ [EDX + ECX * 8 + 16], MM2 MOVNTQ [EDX + ECX * 8 + 24], MM3 MOVNTQ [EDX + ECX * 8 + 32], MM4 MOVNTQ [EDX + ECX * 8 + 40], MM5 MOVNTQ [EDX + ECX * 8 + 48], MM6 MOVNTQ [EDX + ECX * 8 + 56], MM7 ADD ECX, 8 JS @Loop EMMS @PrepSingleLoop: MOV ECX, EBX SHR EBX, 4 SHL EBX, 4 SUB ECX, EBX JZ @Exit LEA EAX, [EAX + ECX * 4] LEA EDX, [EDX + ECX * 4] NEG ECX MOV EDI, Mask @SingleLoop: MOV EBX, [EAX + ECX * 4] OR EBX, EDI MOV [EDX + ECX * 4], EBX INC ECX JNZ @SingleLoop @Exit: POP EDI POP EBX end; procedure AndLineEx_EMMX(Src, Dst: PColor32; Count: Integer; Mask: TColor32); //EMMX version var QMask: Int64; asm PUSH EBX PUSH EDI TEST ECX, ECX JZ @Exit MOV EBX, ECX SHR ECX, 4 SHL ECX, 4 JZ @PrepSingleLoop SAR ECX, 1 LEA EAX, [EAX + ECX * 8] LEA EDX, [EDX + ECX * 8] NEG ECX MOVD MM7, MASK PUNPCKLDQ MM7, MM7 MOVQ QMask, MM7 EMMS @Loop: MOVQ MM0, [EAX + ECX * 8] MOVQ MM1, [EAX + ECX * 8 + 8] MOVQ MM2, [EAX + ECX * 8 + 16] MOVQ MM3, [EAX + ECX * 8 + 24] MOVQ MM4, [EAX + ECX * 8 + 32] MOVQ MM5, [EAX + ECX * 8 + 40] MOVQ MM6, [EAX + ECX * 8 + 48] MOVQ MM7, [EAX + ECX * 8 + 56] PAND MM0, QMask PAND MM1, QMask PAND MM2, QMask PAND MM3, QMask PAND MM4, QMask PAND MM5, QMask PAND MM6, QMask PAND MM7, QMask MOVNTQ [EDX + ECX * 8], MM0 MOVNTQ [EDX + ECX * 8 + 8], MM1 MOVNTQ [EDX + ECX * 8 + 16], MM2 MOVNTQ [EDX + ECX * 8 + 24], MM3 MOVNTQ [EDX + ECX * 8 + 32], MM4 MOVNTQ [EDX + ECX * 8 + 40], MM5 MOVNTQ [EDX + ECX * 8 + 48], MM6 MOVNTQ [EDX + ECX * 8 + 56], MM7 ADD ECX, 8 JS @Loop EMMS @PrepSingleLoop: MOV ECX, EBX SHR EBX, 4 SHL EBX, 4 SUB ECX, EBX JZ @Exit LEA EAX, [EAX + ECX * 4] LEA EDX, [EDX + ECX * 4] NEG ECX MOV EDI, Mask @SingleLoop: MOV EBX, [EAX + ECX * 4] AND EBX, EDI MOV [EDX + ECX * 4], EBX INC ECX JNZ @SingleLoop @Exit: POP EDI POP EBX end; {$ENDIF} {$ENDIF} {CPU target and feature Function templates} const FID_ANDLINE = 0; FID_ORLINE = 1; FID_XORLINE = 2; FID_ANDLINEEX = 3; FID_ORLINEEX = 4; FID_XORLINEEX = 5; var Registry: TFunctionRegistry; procedure RegisterBindings; begin Registry := NewRegistry('GR32_Filters bindings'); Registry.RegisterBinding(FID_ANDLINE, @@LogicalMaskLineAnd); Registry.RegisterBinding(FID_ORLINE, @@LogicalMaskLineOr); Registry.RegisterBinding(FID_XORLINE, @@LogicalMaskLineXor); Registry.RegisterBinding(FID_ANDLINEEX, @@LogicalMaskLineAndEx); Registry.RegisterBinding(FID_ORLINEEX, @@LogicalMaskLineOrEx); Registry.RegisterBinding(FID_XORLINEEX, @@LogicalMaskLineXorEx); Registry.Add(FID_ANDLINE, @AndLine_Pas); Registry.Add(FID_ORLINE, @OrLine_Pas); Registry.Add(FID_XORLINE, @XorLine_Pas); Registry.Add(FID_ANDLINEEX, @AndLineEx_Pas); Registry.Add(FID_ORLINEEX, @OrLineEx_Pas); Registry.Add(FID_XORLINEEX, @XorLineEx_Pas); {$IFNDEF PUREPASCAL} Registry.Add(FID_ANDLINE, @AndLine_ASM); Registry.Add(FID_ORLINE, @OrLine_ASM); Registry.Add(FID_XORLINE, @XorLine_ASM); Registry.Add(FID_ANDLINEEX, @AndLineEx_ASM); Registry.Add(FID_ORLINEEX, @OrLineEx_ASM); Registry.Add(FID_XORLINEEX, @XorLineEx_ASM); {$IFNDEF OMIT_MMX} Registry.Add(FID_ANDLINEEX, @AndLineEx_MMX, [ciMMX]); Registry.Add(FID_ORLINEEX, @OrLineEx_MMX, [ciMMX]); Registry.Add(FID_XORLINEEX, @XorLineEx_MMX, [ciMMX]); Registry.Add(FID_ANDLINEEX, @AndLineEx_EMMX, [ciEMMX]); Registry.Add(FID_ORLINEEX, @OrLineEx_EMMX, [ciEMMX]); Registry.Add(FID_XORLINEEX, @XorLineEx_EMMX, [ciEMMX]); {$ENDIF} {$ENDIF} Registry.RebindAll; end; initialization RegisterBindings; end. |
Added src/graphics32/GR32_Geometry.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 | unit GR32_Geometry; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Additional Math Routines for Graphics32 * * The Initial Developers of the Original Code are * Mattias Andersson <mattias@centaurix.com> * Michael Hansen <dyster_tid@hotmail.com> * * Portions created by the Initial Developers are Copyright (C) 2005-2012 * the Initial Developers. All Rights Reserved. * * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Math, Types, GR32; type TLinePos = (lpStart, lpEnd, lpBoth, lpNeither); // TFloat Overloads function Average(const V1, V2: TFloatPoint): TFloatPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function CrossProduct(V1, V2: TFloatPoint): TFloat; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Dot(const V1, V2: TFloatPoint): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function Distance(const V1, V2: TFloatPoint): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function SqrDistance(const V1, V2: TFloatPoint): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function GetPointAtAngleFromPoint(const Pt: TFloatPoint; const Dist, Radians: Single): TFloatPoint; overload; function GetAngleOfPt2FromPt1(const Pt1, Pt2: TFloatPoint): Single; overload; function GetUnitNormal(const Pt1, Pt2: TFloatPoint): TFloatPoint; overload; function GetUnitVector(const Pt1, Pt2: TFloatPoint): TFloatPoint; overload; function OffsetPoint(const Pt: TFloatPoint; DeltaX, DeltaY: TFloat): TFloatPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetPoint(const Pt, Delta: TFloatPoint): TFloatPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetRect(const Rct: TFloatRect; const DeltaX, DeltaY: TFloat): TFloatRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetRect(const Rct: TFloatRect; const Delta: TFloatPoint): TFloatRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function Shorten(const Pts: TArrayOfFloatPoint; Delta: TFloat; LinePos: TLinePos): TArrayOfFloatPoint; overload; function PointInPolygon(const Pt: TFloatPoint; const Pts: TArrayOfFloatPoint): Boolean; overload; function SegmentIntersect(const P1, P2, P3, P4: TFloatPoint; out IntersectPoint: TFloatPoint): Boolean; overload; function PerpendicularDistance(const P, P1, P2: TFloatPoint): TFloat; overload; // TFixed Overloads function Average(const V1, V2: TFixedPoint): TFixedPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function CrossProduct(V1, V2: TFixedPoint): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function Dot(const V1, V2: TFixedPoint): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function Distance(const V1, V2: TFixedPoint): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function SqrDistance(const V1, V2: TFixedPoint): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function GetPointAtAngleFromPoint(const Pt: TFixedPoint; const Dist, Radians: Single): TFixedPoint; overload; function GetAngleOfPt2FromPt1(Pt1, Pt2: TFixedPoint): Single; overload; function GetUnitVector(const Pt1, Pt2: TFixedPoint): TFloatPoint; overload; function GetUnitNormal(const Pt1, Pt2: TFixedPoint): TFloatPoint; overload; function OffsetPoint(const Pt: TFixedPoint; DeltaX, DeltaY: TFixed): TFixedPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetPoint(const Pt: TFixedPoint; DeltaX, DeltaY: TFloat): TFixedPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetPoint(const Pt: TFixedPoint; const Delta: TFixedPoint): TFixedPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetPoint(const Pt: TFixedPoint; const Delta: TFloatPoint): TFixedPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetRect(const Rct: TFixedRect; const DeltaX, DeltaY: TFixed): TFixedRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetRect(const Rct: TFixedRect; const DeltaX, DeltaY: TFloat): TFixedRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetRect(const Rct: TFixedRect; const Delta: TFixedPoint): TFixedRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetRect(const Rct: TFixedRect; const Delta: TFloatPoint): TFixedRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function Shorten(const Pts: TArrayOfFixedPoint; Delta: TFloat; LinePos: TLinePos): TArrayOfFixedPoint; overload; function PointInPolygon(const Pt: TFixedPoint; const Pts: array of TFixedPoint): Boolean; overload; function SegmentIntersect(const P1, P2, P3, P4: TFixedPoint; out IntersectPoint: TFixedPoint): Boolean; overload; function PerpendicularDistance(const P, P1, P2: TFixedPoint): TFixed; overload; // Integer Overloads function Average(const V1, V2: TPoint): TPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function CrossProduct(V1, V2: TPoint): Integer; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function Dot(const V1, V2: TPoint): Integer; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function Distance(const V1, V2: TPoint): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function SqrDistance(const V1, V2: TPoint): Integer; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetPoint(const Pt: TPoint; DeltaX, DeltaY: Integer): TPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function OffsetPoint(const Pt, Delta: TPoint): TPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} function PerpendicularDistance(const P, P1, P2: TPoint): TFloat; overload; const CRad01 = Pi / 180; CRad30 = Pi / 6; CRad45 = Pi / 4; CRad60 = Pi / 3; CRad90 = Pi / 2; CRad180 = Pi; CRad270 = CRad90 * 3; CRad360 = CRad180 * 2; CDegToRad = Pi / 180; CRadToDeg = 180 / Pi; implementation uses GR32_Math; function Average(const V1, V2: TFloatPoint): TFloatPoint; begin Result.X := (V1.X + V2.X) * 0.5; Result.Y := (V1.Y + V2.Y) * 0.5; end; function CrossProduct(V1, V2: TFloatPoint): TFloat; begin Result := V1.X * V2.Y - V1.Y * V2.X; end; function Dot(const V1, V2: TFloatPoint): TFloat; begin Result := V1.X * V2.X + V1.Y * V2.Y; end; function Distance(const V1, V2: TFloatPoint): TFloat; begin Result := GR32_Math.Hypot(V2.X - V1.X, V2.Y - V1.Y); end; function SqrDistance(const V1, V2: TFloatPoint): TFloat; begin Result := Sqr(V2.X - V1.X) + Sqr(V2.Y - V1.Y); end; function GetPointAtAngleFromPoint(const Pt: TFloatPoint; const Dist, Radians: TFloat): TFloatPoint; overload; var SinAng, CosAng: TFloat; begin GR32_Math.SinCos(Radians, SinAng, CosAng); Result.X := Dist * CosAng + Pt.X; Result.Y := -Dist * SinAng + Pt.Y; // Y axis is positive down end; function GetAngleOfPt2FromPt1(const Pt1, Pt2: TFloatPoint): Single; var X, Y: TFloat; begin X := Pt2.X - Pt1.X; Y := Pt2.Y - Pt1.Y; if X = 0 then begin if Y > 0 then Result := CRad270 else Result := CRad90; end else begin Result := ArcTan2(-Y, X); if Result < 0 then Result := Result + CRad360; end; end; function GetUnitVector(const Pt1, Pt2: TFloatPoint): TFloatPoint; var Delta: TFloatPoint; Temp: TFloat; begin Delta.X := (Pt2.X - Pt1.X); Delta.Y := (Pt2.Y - Pt1.Y); if (Delta.X = 0) and (Delta.Y = 0) then Result := FloatPoint(0, 0) else begin Temp := 1 / GR32_Math.Hypot(Delta.X, Delta.Y); Result.X := Delta.X * Temp; Result.Y := Delta.Y * Temp; end; end; function GetUnitNormal(const Pt1, Pt2: TFloatPoint): TFloatPoint; var Delta: TFloatPoint; Temp: TFloat; begin Delta.X := (Pt2.X - Pt1.X); Delta.Y := (Pt2.Y - Pt1.Y); if (Delta.X = 0) and (Delta.Y = 0) then Result := FloatPoint(0, 0) else begin Temp := 1 / GR32_Math.Hypot(Delta.X, Delta.Y); Delta.X := Delta.X * Temp; Delta.Y := Delta.Y * Temp; end; Result.X := Delta.Y; // ie perpendicular to Result.Y := -Delta.X; // the unit vector end; function OffsetPoint(const Pt: TFloatPoint; DeltaX, DeltaY: TFloat): TFloatPoint; begin Result.X := Pt.X + DeltaX; Result.Y := Pt.Y + DeltaY; end; function OffsetPoint(const Pt, Delta: TFloatPoint): TFloatPoint; begin Result.X := Pt.X + Delta.X; Result.Y := Pt.Y + Delta.Y; end; function OffsetRect(const Rct: TFloatRect; const DeltaX, DeltaY: TFloat): TFloatRect; begin Result.TopLeft := OffsetPoint(Rct.TopLeft, DeltaX, DeltaY); Result.BottomRight := OffsetPoint(Rct.BottomRight, DeltaX, DeltaY); end; function OffsetRect(const Rct: TFloatRect; const Delta: TFloatPoint): TFloatRect; begin Result.TopLeft := OffsetPoint(Rct.TopLeft, Delta); Result.BottomRight := OffsetPoint(Rct.BottomRight, Delta); end; function Shorten(const Pts: TArrayOfFloatPoint; Delta: TFloat; LinePos: TLinePos): TArrayOfFloatPoint; var Index, HighI: integer; Dist, DeltaSqr: TFloat; UnitVec: TFloatPoint; procedure FixStart; begin Index := 1; while (Index < HighI) and (SqrDistance(Pts[Index], Pts[0]) < DeltaSqr) do Inc(Index); UnitVec := GetUnitVector(Pts[Index], Pts[0]); Dist := Distance(Pts[Index], Pts[0]) - Delta; if Index > 1 then begin HighI := HighI - Index + 1; Move(Result[Index], Result[1], SizeOf(TFloatPoint) * HighI); SetLength(Result, HighI + 1); end; Result[0] := OffsetPoint(Result[1], UnitVec.X * Dist, UnitVec.Y * Dist); end; procedure FixEnd; begin Index := HighI - 1; while (Index > 0) and (SqrDistance(Pts[Index],Pts[HighI]) < DeltaSqr) do Dec(Index); UnitVec := GetUnitVector(Pts[Index],Pts[HighI]); Dist := Distance(Pts[Index], Pts[HighI]) - Delta; if Index + 1 < HighI then SetLength(Result, Index + 2); Result[Index + 1] := OffsetPoint(Result[Index], UnitVec.X * Dist, UnitVec.Y * Dist); end; begin Result := Pts; HighI := High(Pts); DeltaSqr := Delta * Delta; if HighI < 1 then Exit; case LinePos of lpStart: FixStart; lpEnd : FixEnd; lpBoth : begin FixStart; FixEnd; end; end; end; function PointInPolygon(const Pt: TFloatPoint; const Pts: TArrayOfFloatPoint): Boolean; var Index: Integer; iPt, jPt: PFloatPoint; begin Result := False; iPt := @Pts[0]; jPt := @Pts[High(Pts)]; for Index := 0 to High(Pts) do begin Result := Result xor (((Pt.Y >= iPt.Y) xor (Pt.Y >= jPt.Y)) and ((Pt.X - iPt.X) < ((jPt.X - iPt.X) * (Pt.Y -iPt.Y) / (jPt.Y - iPt.Y)))); jPt := iPt; Inc(iPt); end; end; function SegmentIntersect(const P1, P2, P3, P4: TFloatPoint; out IntersectPoint: TFloatPoint): Boolean; var m1, b1, m2, b2: TFloat; begin // see http://astronomy.swin.edu.au/~pbourke/geometry/lineline2d/ Result := False; if (P2.X = P1.X) then begin if (P4.X = P3.X) then Exit; // parallel lines m2 := (P4.Y - P3.Y) / (P4.X - P3.X); b2 := P3.Y - m2 * P3.X; IntersectPoint.X := P1.X; IntersectPoint.Y := m2 * P1.X + b2; Result := (((IntersectPoint.Y < P2.Y) = (IntersectPoint.Y > P1.Y)) or (IntersectPoint.Y = P2.Y) or (IntersectPoint.Y = P1.Y)) and (((IntersectPoint.Y < P3.Y) = (IntersectPoint.Y > P4.Y)) or (IntersectPoint.Y = P3.Y) or (IntersectPoint.Y = P4.Y)); end else if (P4.X = P3.X) then begin m1 := (P2.Y - P1.Y) / (P2.X - P1.X); b1 := P1.Y - m1 * P1.X; IntersectPoint.X := P3.X; IntersectPoint.Y := m1 * P3.X + b1; Result := (((IntersectPoint.Y < P2.Y) = (IntersectPoint.Y > P1.Y)) or (IntersectPoint.Y = P2.Y) or (IntersectPoint.Y = P1.Y)) and (((IntersectPoint.Y < P3.Y) = (IntersectPoint.Y > P4.Y)) or (IntersectPoint.Y = P3.Y) or (IntersectPoint.Y = P4.Y)); end else begin m1 := (P2.Y - P1.Y) / (P2.X - P1.X); b1 := P1.Y - m1 * P1.X; m2 := (P4.Y - P3.Y) / (P4.X - P3.X); b2 := P3.Y - m2 * P3.X; if m1 = m2 then Exit; // parallel lines IntersectPoint.X := (b2 - b1) / (m1 - m2); IntersectPoint.Y := m1 * IntersectPoint.X + b1; Result := (((IntersectPoint.X < P2.X) = (IntersectPoint.X > P1.X)) or (IntersectPoint.X = P2.X) or (IntersectPoint.X = P1.X)) and (((IntersectPoint.X < P3.X) = (IntersectPoint.X > P4.X)) or (IntersectPoint.X = P3.X) or (IntersectPoint.X = P4.X)); end; end; function PerpendicularDistance(const P, P1, P2: TFloatPoint): TFloat; begin Result := Abs((P.x - P2.x) * (P1.y - P2.y) - (P.y - P2.y) * (P1.x - P2.x)) / GR32_Math.Hypot(P1.x - P2.x, P1.y - P2.y); end; // Fixed overloads function Average(const V1, V2: TFixedPoint): TFixedPoint; begin Result.X := (V1.X + V2.X) div 2; Result.Y := (V1.Y + V2.Y) div 2; end; function CrossProduct(V1, V2: TFixedPoint): TFixed; begin Result := FixedMul(V1.X, V2.Y) - FixedMul(V1.Y, V2.X); end; function Dot(const V1, V2: TFixedPoint): TFixed; begin Result := FixedMul(V1.X, V2.X) + FixedMul(V1.Y, V2.Y); end; function Distance(const V1, V2: TFixedPoint): TFixed; begin Result := Fixed(Hypot((V2.X - V1.X) * FixedToFloat, (V2.Y - V1.Y) * FixedToFloat)); end; function SqrDistance(const V1, V2: TFixedPoint): TFixed; begin Result := FixedSqr(V2.X - V1.X) + FixedSqr(V2.Y - V1.Y); end; function GetPointAtAngleFromPoint(const Pt: TFixedPoint; const Dist, Radians: TFloat): TFixedPoint; var SinAng, CosAng: TFloat; begin GR32_Math.SinCos(Radians, SinAng, CosAng); Result.X := Round(Dist * CosAng * FixedOne) + Pt.X; Result.Y := -Round(Dist * SinAng * FixedOne) + Pt.Y; // Y axis is positive down end; function GetAngleOfPt2FromPt1(Pt1, Pt2: TFixedPoint): Single; begin with Pt2 do begin X := X - Pt1.X; Y := Y - Pt1.Y; if X = 0 then begin if Y > 0 then Result := CRad270 else Result := CRad90; end else begin Result := ArcTan2(-Y,X); if Result < 0 then Result := Result + CRad360; end; end; end; function GetUnitVector(const Pt1, Pt2: TFixedPoint): TFloatPoint; var Delta: TFloatPoint; Temp: Single; begin Delta.X := (Pt2.X - Pt1.X) * FixedToFloat; Delta.Y := (Pt2.Y - Pt1.Y) * FixedToFloat; if (Delta.X = 0) and (Delta.Y = 0) then begin Result := FloatPoint(0,0); end else begin Temp := 1 / GR32_Math.Hypot(Delta.X, Delta.Y); Result.X := Delta.X * Temp; Result.Y := Delta.Y * Temp; end; end; function GetUnitNormal(const Pt1, Pt2: TFixedPoint): TFloatPoint; var Delta: TFloatPoint; Temp: Single; begin Delta.X := (Pt2.X - Pt1.X) * FixedToFloat; Delta.Y := (Pt2.Y - Pt1.Y) * FixedToFloat; if (Delta.X = 0) and (Delta.Y = 0) then begin Result := FloatPoint(0,0); end else begin Temp := 1 / GR32_Math.Hypot(Delta.X, Delta.Y); Delta.X := Delta.X * Temp; Delta.Y := Delta.Y * Temp; end; Result.X := Delta.Y; // ie perpendicular to Result.Y := -Delta.X; // the unit vector end; function OffsetPoint(const Pt: TFixedPoint; DeltaX, DeltaY: TFixed): TFixedPoint; begin Result.X := Pt.X + DeltaX; Result.Y := Pt.Y + DeltaY; end; function OffsetPoint(const Pt: TFixedPoint; DeltaX, DeltaY: TFloat): TFixedPoint; begin Result.X := Pt.X + Fixed(DeltaX); Result.Y := Pt.Y + Fixed(DeltaY); end; function OffsetPoint(const Pt: TFixedPoint; const Delta: TFixedPoint): TFixedPoint; begin Result.X := Pt.X + Delta.X; Result.Y := Pt.Y + Delta.Y; end; function OffsetPoint(const Pt: TFixedPoint; const Delta: TFloatPoint): TFixedPoint; begin Result.X := Pt.X + Fixed(Delta.X); Result.Y := Pt.Y + Fixed(Delta.Y); end; function OffsetRect(const Rct: TFixedRect; const DeltaX, DeltaY: TFixed): TFixedRect; begin Result.TopLeft := OffsetPoint(Rct.TopLeft, DeltaX, DeltaY); Result.BottomRight := OffsetPoint(Rct.BottomRight, DeltaX, DeltaY); end; function OffsetRect(const Rct: TFixedRect; const Delta: TFixedPoint): TFixedRect; begin Result.TopLeft := OffsetPoint(Rct.TopLeft, Delta); Result.BottomRight := OffsetPoint(Rct.BottomRight, Delta); end; function OffsetRect(const Rct: TFixedRect; const DeltaX, DeltaY: TFloat): TFixedRect; var DX, DY: TFixed; begin DX := Fixed(DeltaX); DY := Fixed(DeltaY); Result.TopLeft := OffsetPoint(Rct.TopLeft, DX, DY); Result.BottomRight := OffsetPoint(Rct.BottomRight, DX, DY); end; function OffsetRect(const Rct: TFixedRect; const Delta: TFloatPoint): TFixedRect; var DX, DY: TFixed; begin DX := Fixed(Delta.X); DY := Fixed(Delta.Y); Result.TopLeft := OffsetPoint(Rct.TopLeft, DX, DY); Result.BottomRight := OffsetPoint(Rct.BottomRight, DX, DY); end; function Shorten(const Pts: TArrayOfFixedPoint; Delta: TFloat; LinePos: TLinePos): TArrayOfFixedPoint; var Index, HighI: integer; Dist, DeltaSqr: TFloat; UnitVec: TFloatPoint; procedure FixStart; begin Index := 1; while (Index < HighI) and (SqrDistance(Pts[Index],Pts[0]) < DeltaSqr) do Inc(Index); UnitVec := GetUnitVector(Pts[Index], Pts[0]); Dist := Distance(Pts[Index],Pts[0]) - Delta; if Index > 1 then begin Move(Result[Index], Result[1], SizeOf(TFloatPoint) * (HighI - Index + 1)); SetLength(Result, HighI - Index + 2); HighI := HighI - Index + 1; end; Result[0] := OffsetPoint(Result[1], UnitVec.X * Dist, UnitVec.Y * Dist); end; procedure FixEnd; begin Index := HighI -1; while (Index > 0) and (SqrDistance(Pts[Index],Pts[HighI]) < DeltaSqr) do Dec(Index); UnitVec := GetUnitVector(Pts[Index],Pts[HighI]); Dist := Distance(Pts[Index],Pts[HighI]) - Delta; if Index + 1 < HighI then SetLength(Result, Index + 2); Result[Index + 1] := OffsetPoint(Result[Index], UnitVec.X * Dist, UnitVec.Y * Dist); end; begin Result := Pts; HighI := High(Pts); DeltaSqr := Delta * Delta; if HighI < 1 then Exit; case LinePos of lpStart: FixStart; lpEnd : FixEnd; lpBoth : begin FixStart; FixEnd; end; end; end; function PointInPolygon(const Pt: TFixedPoint; const Pts: array of TFixedPoint): Boolean; var I: Integer; iPt, jPt: PFixedPoint; begin Result := False; iPt := @Pts[0]; jPt := @Pts[High(Pts)]; for I := 0 to High(Pts) do begin Result := Result xor (((Pt.Y >= iPt.Y) xor (Pt.Y >= jPt.Y)) and (Pt.X - iPt.X < MulDiv(jPt.X - iPt.X, Pt.Y - iPt.Y, jPt.Y - iPt.Y))); jPt := iPt; Inc(iPt); end; end; function SegmentIntersect(const P1, P2, P3, P4: TFixedPoint; out IntersectPoint: TFixedPoint): Boolean; var m1,b1,m2,b2: TFloat; begin Result := False; if (P2.X = P1.X) then begin if (P4.X = P3.X) then Exit; // parallel lines m2 := (P4.Y - P3.Y) / (P4.X - P3.X); b2 := P3.Y - m2 * P3.X; IntersectPoint.X := P1.X; IntersectPoint.Y := Round(m2 * P1.X + b2); Result := (IntersectPoint.Y < P2.Y) = (IntersectPoint.Y > P1.Y); end else if (P4.X = P3.X) then begin m1 := (P2.Y - P1.Y) / (P2.X - P1.X); b1 := P1.Y - m1 * P1.X; IntersectPoint.X := P3.X; IntersectPoint.Y := Round(m1 * P3.X + b1); Result := (IntersectPoint.Y < P3.Y) = (IntersectPoint.Y > P4.Y); end else begin m1 := (P2.Y - P1.Y) / (P2.X - P1.X); b1 := P1.Y - m1 * P1.X; m2 := (P4.Y - P3.Y) / (P4.X - P3.X); b2 := P3.Y - m2 * P3.X; if m1 = m2 then Exit; // parallel lines IntersectPoint.X := Round((b2 - b1) / (m1 - m2)); IntersectPoint.Y := Round(m1 * IntersectPoint.X + b1); Result := ((IntersectPoint.X < P2.X) = (IntersectPoint.X > P1.X)); end; end; function PerpendicularDistance(const P, P1, P2: TFixedPoint): TFixed; begin Result := Fixed(Abs((P.x - P2.x) * (P1.y - P2.y) - (P.y - P2.y) * (P1.x - P2.x)) * FixedToFloat / Hypot((P1.x - P2.x) * FixedToFloat, (P1.y - P2.y) * FixedToFloat)); end; // Integer overloads function Average(const V1, V2: TPoint): TPoint; begin Result.X := (V1.X + V2.X) div 2; Result.Y := (V1.Y + V2.Y) div 2; end; function CrossProduct(V1, V2: TPoint): Integer; begin Result := V1.X * V2.Y - V1.Y * V2.X; end; function Dot(const V1, V2: TPoint): Integer; begin Result := V1.X * V2.X + V1.Y * V2.Y; end; function Distance(const V1, V2: TPoint): TFloat; begin Result := Hypot(Integer(V2.X - V1.X), Integer(V2.Y - V1.Y)); end; function SqrDistance(const V1, V2: TPoint): Integer; begin Result := Sqr(V2.X - V1.X) + Sqr(V2.Y - V1.Y); end; function OffsetPoint(const Pt: TPoint; DeltaX, DeltaY: Integer): TPoint; begin Result.X := Pt.X + DeltaX; Result.Y := Pt.Y + DeltaY; end; function OffsetPoint(const Pt, Delta: TPoint): TPoint; begin Result.X := Pt.X + Delta.X; Result.Y := Pt.Y + Delta.Y; end; function PerpendicularDistance(const P, P1, P2: TPoint): TFloat; begin Result := Abs((P.x - P2.x) * (P1.y - P2.y) - (P.y - P2.y) * (P1.x - P2.x)) / Math.Hypot(P1.x - P2.x, P1.y - P2.y); end; end. |
Added src/graphics32/GR32_Image.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 | unit GR32_Image; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Mattias Andersson <mattias@centaurix.com> * Andre Beckedorf <Andre@metaException.de> * Andrew P. Rybin <aprybin@users.sourceforge.net> * Dieter Köhler <dieter.koehler@philo.de> * Michael Hansen <dyster_tid@hotmail.com> * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LCLType, LMessages, Types, {$ELSE} Windows, Messages, {$ENDIF} Graphics, Controls, Forms, Classes, SysUtils, GR32, GR32_Layers, GR32_RangeBars, GR32_Containers, GR32_RepaintOpt; const { Paint Stage Constants } PST_CUSTOM = 1; // Calls OnPaint with # of current stage in parameter PST_CLEAR_BUFFER = 2; // Clears the buffer PST_CLEAR_BACKGND = 3; // Clears a visible buffer area PST_DRAW_BITMAP = 4; // Draws a bitmap PST_DRAW_LAYERS = 5; // Draw layers (Parameter = Layer Mask) PST_CONTROL_FRAME = 6; // Draws a dotted frame around the control PST_BITMAP_FRAME = 7; // Draws a dotted frame around the scaled bitmap type TPaintStageEvent = procedure(Sender: TObject; Buffer: TBitmap32; StageNum: Cardinal) of object; { TPaintStage } PPaintStage = ^TPaintStage; TPaintStage = record DsgnTime: Boolean; RunTime: Boolean; Stage: Cardinal; // a PST_* constant Parameter: Cardinal; // an optional parameter end; { TPaintStages } TPaintStages = class private FItems: array of TPaintStage; function GetItem(Index: Integer): PPaintStage; public destructor Destroy; override; function Add: PPaintStage; procedure Clear; function Count: Integer; procedure Delete(Index: Integer); function Insert(Index: Integer): PPaintStage; property Items[Index: Integer]: PPaintStage read GetItem; default; end; { Alignment of the bitmap in TCustomImage32 } TBitmapAlign = (baTopLeft, baCenter, baTile, baCustom); TScaleMode = (smNormal, smStretch, smScale, smResize, smOptimal, smOptimalScaled); TPaintBoxOptions = set of (pboWantArrowKeys, pboAutoFocus); TRepaintMode = (rmFull, rmDirect, rmOptimizer); { TCustomPaintBox32 } TCustomPaintBox32 = class(TCustomControl) private FBuffer: TBitmap32; FBufferOversize: Integer; FBufferValid: Boolean; FRepaintMode: TRepaintMode; FInvalidRects: TRectList; FForceFullRepaint: Boolean; FRepaintOptimizer: TCustomRepaintOptimizer; FOptions: TPaintBoxOptions; FOnGDIOverlay: TNotifyEvent; FMouseInControl: Boolean; FOnMouseEnter: TNotifyEvent; FOnMouseLeave: TNotifyEvent; procedure SetBufferOversize(Value: Integer); {$IFDEF FPC} procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; procedure WMGetDlgCode(var Msg: TLMessage); message LM_GETDLGCODE; procedure WMPaint(var Message: TLMPaint); message LM_PAINT; procedure CMMouseEnter(var Message: TLMessage); message LM_MOUSEENTER; procedure CMMouseLeave(var Message: TLMessage); message LM_MOUSELEAVE; {$ELSE} procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND; procedure WMGetDlgCode(var Msg: TWmGetDlgCode); message WM_GETDLGCODE; procedure WMPaint(var Message: TMessage); message WM_PAINT; procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; procedure CMInvalidate(var Message: TMessage); message CM_INVALIDATE; {$ENDIF} procedure DirectAreaUpdateHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); protected procedure SetRepaintMode(const Value: TRepaintMode); virtual; function CustomRepaint: Boolean; virtual; function InvalidRectsAvailable: Boolean; virtual; procedure DoPrepareInvalidRects; virtual; procedure DoPaintBuffer; virtual; procedure DoPaintGDIOverlay; virtual; procedure DoBufferResized(const OldWidth, OldHeight: Integer); virtual; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseEnter; {$IFDEF FPC} override; {$ELSE} virtual; {$ENDIF} procedure MouseLeave; {$IFDEF FPC} override; {$ELSE} virtual; {$ENDIF} procedure Paint; override; procedure ResetInvalidRects; procedure ResizeBuffer; property RepaintOptimizer: TCustomRepaintOptimizer read FRepaintOptimizer; property BufferValid: Boolean read FBufferValid write FBufferValid; property InvalidRects: TRectList read FInvalidRects; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetViewportRect: TRect; virtual; procedure Flush; overload; procedure Flush(const SrcRect: TRect); overload; procedure Invalidate; override; procedure ForceFullInvalidate; virtual; procedure Loaded; override; procedure Resize; override; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; procedure AssignTo(Dest: TPersistent); override; property Buffer: TBitmap32 read FBuffer; property BufferOversize: Integer read FBufferOversize write SetBufferOversize; property Options: TPaintBoxOptions read FOptions write FOptions default []; property MouseInControl: Boolean read FMouseInControl; property RepaintMode: TRepaintMode read FRepaintMode write SetRepaintMode default rmFull; property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave; property OnGDIOverlay: TNotifyEvent read FOnGDIOverlay write FOnGDIOverlay; end; { TPaintBox32 } TPaintBox32 = class(TCustomPaintBox32) private FOnPaintBuffer: TNotifyEvent; protected procedure DoPaintBuffer; override; public property Canvas; published property Align; property Anchors; property AutoSize; property Constraints; property Cursor; property DragCursor; property DragMode; property Options; property ParentShowHint; property PopupMenu; property RepaintMode; property ShowHint; property TabOrder; property TabStop; property Visible; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnGDIOverlay; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnMouseEnter; property OnMouseLeave; property OnPaintBuffer: TNotifyEvent read FOnPaintBuffer write FOnPaintBuffer; property OnResize; property OnStartDrag; end; { TCustomImage32 } TImgMouseEvent = procedure(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer) of object; TImgMouseMoveEvent = procedure(Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer) of object; TPaintStageHandler = procedure(Dest: TBitmap32; StageNum: Integer) of object; TCustomImage32 = class(TCustomPaintBox32) private FBitmap: TBitmap32; FBitmapAlign: TBitmapAlign; FLayers: TLayerCollection; FOffsetHorz: TFloat; FOffsetVert: TFloat; FPaintStages: TPaintStages; FPaintStageHandlers: array of TPaintStageHandler; FPaintStageNum: array of Integer; FScaleX: TFloat; FScaleY: TFloat; FScaleMode: TScaleMode; FUpdateCount: Integer; FOnBitmapResize: TNotifyEvent; FOnChange: TNotifyEvent; FOnInitStages: TNotifyEvent; FOnMouseDown: TImgMouseEvent; FOnMouseMove: TImgMouseMoveEvent; FOnMouseUp: TImgMouseEvent; FOnPaintStage: TPaintStageEvent; FOnScaleChange: TNotifyEvent; procedure BitmapResizeHandler(Sender: TObject); procedure BitmapChangeHandler(Sender: TObject); procedure BitmapAreaChangeHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); procedure BitmapDirectAreaChangeHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); procedure LayerCollectionChangeHandler(Sender: TObject); procedure LayerCollectionGDIUpdateHandler(Sender: TObject); procedure LayerCollectionGetViewportScaleHandler(Sender: TObject; out ScaleX, ScaleY: TFloat); procedure LayerCollectionGetViewportShiftHandler(Sender: TObject; out ShiftX, ShiftY: TFloat); function GetOnPixelCombine: TPixelCombineEvent; procedure SetBitmap(Value: TBitmap32); procedure SetBitmapAlign(Value: TBitmapAlign); procedure SetLayers(Value: TLayerCollection); procedure SetOffsetHorz(Value: TFloat); procedure SetOffsetVert(Value: TFloat); procedure SetScale(Value: TFloat); procedure SetScaleX(Value: TFloat); procedure SetScaleY(Value: TFloat); procedure SetOnPixelCombine(Value: TPixelCombineEvent); protected CachedBitmapRect: TRect; CachedShiftX, CachedShiftY, CachedScaleX, CachedScaleY, CachedRecScaleX, CachedRecScaleY: TFloat; CacheValid: Boolean; OldSzX, OldSzY: Integer; PaintToMode: Boolean; procedure BitmapResized; virtual; procedure BitmapChanged(const Area: TRect); reintroduce; virtual; function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override; procedure DoInitStages; virtual; procedure DoPaintBuffer; override; procedure DoPaintGDIOverlay; override; procedure DoScaleChange; virtual; procedure InitDefaultStages; virtual; procedure InvalidateCache; function InvalidRectsAvailable: Boolean; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); overload; override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); overload; override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); overload; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); reintroduce; overload; virtual; procedure MouseMove(Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); reintroduce; overload; virtual; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); reintroduce; overload; virtual; procedure MouseLeave; override; procedure SetRepaintMode(const Value: TRepaintMode); override; procedure SetScaleMode(Value: TScaleMode); virtual; procedure SetXForm(ShiftX, ShiftY, ScaleX, ScaleY: TFloat); procedure UpdateCache; virtual; property UpdateCount: Integer read FUpdateCount; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure BeginUpdate; virtual; function BitmapToControl(const APoint: TPoint): TPoint; overload; function BitmapToControl(const APoint: TFloatPoint): TFloatPoint; overload; procedure Changed; virtual; procedure Update(const Rect: TRect); reintroduce; overload; virtual; function ControlToBitmap(const APoint: TPoint): TPoint; overload; function ControlToBitmap(const APoint: TFloatPoint): TFloatPoint; overload; procedure EndUpdate; virtual; procedure ExecBitmapFrame(Dest: TBitmap32; StageNum: Integer); virtual; // PST_BITMAP_FRAME procedure ExecClearBuffer(Dest: TBitmap32; StageNum: Integer); virtual; // PST_CLEAR_BUFFER procedure ExecClearBackgnd(Dest: TBitmap32; StageNum: Integer); virtual; // PST_CLEAR_BACKGND procedure ExecControlFrame(Dest: TBitmap32; StageNum: Integer); virtual; // PST_CONTROL_FRAME procedure ExecCustom(Dest: TBitmap32; StageNum: Integer); virtual; // PST_CUSTOM procedure ExecDrawBitmap(Dest: TBitmap32; StageNum: Integer); virtual; // PST_DRAW_BITMAP procedure ExecDrawLayers(Dest: TBitmap32; StageNum: Integer); virtual; // PST_DRAW_LAYERS function GetBitmapRect: TRect; virtual; function GetBitmapSize: TSize; virtual; procedure Invalidate; override; procedure Loaded; override; procedure PaintTo(Dest: TBitmap32; DestRect: TRect); virtual; procedure Resize; override; procedure SetupBitmap(DoClear: Boolean = False; ClearColor: TColor32 = $FF000000); virtual; property Bitmap: TBitmap32 read FBitmap write SetBitmap; property BitmapAlign: TBitmapAlign read FBitmapAlign write SetBitmapAlign; property Canvas; property Layers: TLayerCollection read FLayers write SetLayers; property OffsetHorz: TFloat read FOffsetHorz write SetOffsetHorz; property OffsetVert: TFloat read FOffsetVert write SetOffsetVert; property PaintStages: TPaintStages read FPaintStages; property Scale: TFloat read FScaleX write SetScale; property ScaleX: TFloat read FScaleX write SetScaleX; property ScaleY: TFloat read FScaleY write SetScaleY; property ScaleMode: TScaleMode read FScaleMode write SetScaleMode; property OnBitmapResize: TNotifyEvent read FOnBitmapResize write FOnBitmapResize; property OnBitmapPixelCombine: TPixelCombineEvent read GetOnPixelCombine write SetOnPixelCombine; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnInitStages: TNotifyEvent read FOnInitStages write FOnInitStages; property OnMouseDown: TImgMouseEvent read FOnMouseDown write FOnMouseDown; property OnMouseMove: TImgMouseMoveEvent read FOnMouseMove write FOnMouseMove; property OnMouseUp: TImgMouseEvent read FOnMouseUp write FOnMouseUp; property OnPaintStage: TPaintStageEvent read FOnPaintStage write FOnPaintStage; property OnScaleChange: TNotifyEvent read FOnScaleChange write FOnScaleChange; end; TImage32 = class(TCustomImage32) published property Align; property Anchors; property AutoSize; property Bitmap; property BitmapAlign; property Color; property Constraints; property Cursor; property DragCursor; property DragMode; property ParentColor; property ParentShowHint; property PopupMenu; property RepaintMode; property Scale; property ScaleMode; property ShowHint; property TabOrder; property TabStop; property Visible; property OnBitmapResize; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnClick; property OnChange; property OnContextPopup; property OnDblClick; property OnGDIOverlay; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnInitStages; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnMouseEnter; property OnMouseLeave; property OnPaintStage; property OnResize; property OnStartDrag; end; TCustomImgView32 = class; TScrollBarVisibility = (svAlways, svHidden, svAuto); { TIVScrollProperties } TIVScrollProperties = class(TArrowBarAccess) private function GetIncrement: Integer; function GetSize: Integer; function GetVisibility: TScrollbarVisibility; procedure SetIncrement(Value: Integer); procedure SetSize(Value: Integer); procedure SetVisibility(const Value: TScrollbarVisibility); protected ImgView: TCustomImgView32; published property Increment: Integer read GetIncrement write SetIncrement default 8; property Size: Integer read GetSize write SetSize default 0; property Visibility: TScrollBarVisibility read GetVisibility write SetVisibility default svAlways; end; TSizeGripStyle = (sgAuto, sgNone, sgAlways); { TCustomImgView32 } TCustomImgView32 = class(TCustomImage32) private FCentered: Boolean; FScrollBarSize: Integer; FScrollBarVisibility: TScrollBarVisibility; FScrollBars: TIVScrollProperties; FSizeGrip: TSizeGripStyle; FOnScroll: TNotifyEvent; FOverSize: Integer; procedure SetCentered(Value: Boolean); procedure SetScrollBars(Value: TIVScrollProperties); procedure SetSizeGrip(Value: TSizeGripStyle); procedure SetOverSize(const Value: Integer); protected DisableScrollUpdate: Boolean; HScroll: TCustomRangeBar; VScroll: TCustomRangeBar; procedure AlignAll; procedure BitmapResized; override; procedure DoDrawSizeGrip(R: TRect); procedure DoScaleChange; override; procedure DoScroll; virtual; function GetScrollBarsVisible: Boolean; function GetScrollBarSize: Integer; function GetSizeGripRect: TRect; function IsSizeGripVisible: Boolean; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure Paint; override; procedure Recenter; procedure SetScaleMode(Value: TScaleMode); override; procedure ScrollHandler(Sender: TObject); virtual; procedure UpdateImage; virtual; procedure UpdateScrollBars; virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetViewportRect: TRect; override; procedure Loaded; override; procedure Resize; override; procedure ScrollToCenter(X, Y: Integer); procedure Scroll(Dx, Dy: Integer); property Centered: Boolean read FCentered write SetCentered default True; property ScrollBars: TIVScrollProperties read FScrollBars write SetScrollBars; property SizeGrip: TSizeGripStyle read FSizeGrip write SetSizeGrip default sgAuto; property OverSize: Integer read FOverSize write SetOverSize; property OnScroll: TNotifyEvent read FOnScroll write FOnScroll; end; TImgView32 = class(TCustomImgView32) property Align; property Anchors; property AutoSize; property Bitmap; property BitmapAlign; property Centered; property Color; property Constraints; property Cursor; property DragCursor; property DragMode; property ParentColor; property ParentShowHint; property PopupMenu; property RepaintMode; property Scale; property ScaleMode; property ScrollBars; property ShowHint; property SizeGrip; property OverSize; property TabOrder; property TabStop; property Visible; property OnBitmapResize; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnClick; property OnChange; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnGDIOverlay; property OnInitStages; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnPaintStage; property OnResize; property OnScroll; property OnStartDrag; end; { TBitmap32Item } { A bitmap container designed to be inserted into TBitmap32Collection } TBitmap32Item = class(TCollectionItem) private FBitmap: TBitmap32; procedure SetBitmap(ABitmap: TBitmap32); protected procedure AssignTo(Dest: TPersistent); override; public constructor Create(Collection: TCollection); override; destructor Destroy; override; published property Bitmap: TBitmap32 read FBitmap write SetBitmap; end; TBitmap32ItemClass = class of TBitmap32Item; { TBitmap32Collection } { A collection of TBitmap32Item objects } TBitmap32Collection = class(TCollection) private FOwner: TPersistent; function GetItem(Index: Integer): TBitmap32Item; procedure SetItem(Index: Integer; Value: TBitmap32Item); protected function GetOwner: TPersistent; override; public constructor Create(AOwner: TPersistent; ItemClass: TBitmap32ItemClass); function Add: TBitmap32Item; property Items[Index: Integer]: TBitmap32Item read GetItem write SetItem; default; end; { TBitmap32List } { A component that stores TBitmap32Collection } TBitmap32List = class(TComponent) private FBitmap32Collection: TBitmap32Collection; procedure SetBitmap(Index: Integer; Value: TBitmap32); function GetBitmap(Index: Integer): TBitmap32; procedure SetBitmap32Collection(Value: TBitmap32Collection); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Bitmap[Index: Integer]: TBitmap32 read GetBitmap write SetBitmap; default; published property Bitmaps: TBitmap32Collection read FBitmap32Collection write SetBitmap32Collection; end; implementation uses Math, TypInfo, GR32_MicroTiles, GR32_Backends, GR32_XPThemes; type TLayerAccess = class(TCustomLayer); TLayerCollectionAccess = class(TLayerCollection); TRangeBarAccess = class(TRangeBar); const DefaultRepaintOptimizerClass: TCustomRepaintOptimizerClass = TMicroTilesRepaintOptimizer; resourcestring RCStrInvalidStageIndex = 'Invalid stage index'; { TPaintStages } function TPaintStages.Add: PPaintStage; var L: Integer; begin L := Length(FItems); SetLength(FItems, L + 1); Result := @FItems[L]; with Result^ do begin DsgnTime := False; RunTime := True; Stage := 0; Parameter := 0; end; end; procedure TPaintStages.Clear; begin FItems := nil; end; function TPaintStages.Count: Integer; begin Result := Length(FItems); end; procedure TPaintStages.Delete(Index: Integer); var Count: Integer; begin if (Index < 0) or (Index > High(FItems)) then raise EListError.Create(RCStrInvalidStageIndex); Count := Length(FItems) - Index - 1; if Count > 0 then Move(FItems[Index + 1], FItems[Index], Count * SizeOf(TPaintStage)); SetLength(FItems, High(FItems)); end; destructor TPaintStages.Destroy; begin Clear; inherited; end; function TPaintStages.GetItem(Index: Integer): PPaintStage; begin Result := @FItems[Index]; end; function TPaintStages.Insert(Index: Integer): PPaintStage; var Count: Integer; begin if Index < 0 then Index := 0 else if Index > Length(FItems) then Index := Length(FItems); Count := Length(FItems) - Index; SetLength(FItems, Length(FItems) + 1); if Count > 0 then Move(FItems[Index], FItems[Index + 1], Count * SizeOf(TPaintStage)); Result := @FItems[Index]; with Result^ do begin DsgnTime := False; RunTime := True; Stage := 0; Parameter := 0; end; end; { TCustomPaintBox32 } {$IFNDEF FPC} procedure TCustomPaintBox32.CMInvalidate(var Message: TMessage); begin if CustomRepaint and HandleAllocated then // we might have invalid rects, so just go ahead without invalidating // the whole client area... PostMessage(Handle, WM_PAINT, 0, 0) else // no invalid rects, so just invalidate the whole client area... inherited; end; {$ENDIF} procedure TCustomPaintBox32.AssignTo(Dest: TPersistent); begin inherited AssignTo(Dest); if Dest is TCustomPaintBox32 then begin FBuffer.Assign(TCustomPaintBox32(Dest).FBuffer); TCustomPaintBox32(Dest).FBufferOversize := FBufferOversize; TCustomPaintBox32(Dest).FBufferValid := FBufferValid; TCustomPaintBox32(Dest).FRepaintMode := FRepaintMode; TCustomPaintBox32(Dest).FInvalidRects := FInvalidRects; TCustomPaintBox32(Dest).FForceFullRepaint := FForceFullRepaint; TCustomPaintBox32(Dest).FOptions := FOptions; TCustomPaintBox32(Dest).FOnGDIOverlay := FOnGDIOverlay; TCustomPaintBox32(Dest).FOnMouseEnter := FOnMouseEnter; TCustomPaintBox32(Dest).FOnMouseLeave := FOnMouseLeave; end; end; procedure TCustomPaintBox32.CMMouseEnter(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF}); begin inherited; MouseEnter; end; procedure TCustomPaintBox32.CMMouseLeave(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF}); begin MouseLeave; inherited; end; constructor TCustomPaintBox32.Create(AOwner: TComponent); begin inherited; FBuffer := TBitmap32.Create; FBufferOversize := 40; FForceFullRepaint := True; FInvalidRects := TRectList.Create; FRepaintOptimizer := DefaultRepaintOptimizerClass.Create(Buffer, InvalidRects); { Setting a initial size here will cause the control to crash under LCL } {$IFNDEF FPC} Height := 192; Width := 192; {$ENDIF} end; destructor TCustomPaintBox32.Destroy; begin FRepaintOptimizer.Free; FInvalidRects.Free; FBuffer.Free; inherited; end; procedure TCustomPaintBox32.DoBufferResized(const OldWidth, OldHeight: Integer); begin if FRepaintOptimizer.Enabled then FRepaintOptimizer.BufferResizedHandler(FBuffer.Width, FBuffer.Height); end; function TCustomPaintBox32.CustomRepaint: Boolean; begin Result := FRepaintOptimizer.Enabled and not FForceFullRepaint and FRepaintOptimizer.UpdatesAvailable; end; procedure TCustomPaintBox32.DoPrepareInvalidRects; begin if FRepaintOptimizer.Enabled and not FForceFullRepaint then FRepaintOptimizer.PerformOptimization; end; function TCustomPaintBox32.InvalidRectsAvailable: Boolean; begin Result := True; end; procedure TCustomPaintBox32.DoPaintBuffer; begin // force full repaint, this is necessary when Buffer is invalid and was never painted // This will omit calculating the invalid rects, thus we paint everything. if FForceFullRepaint then begin FForceFullRepaint := False; FInvalidRects.Clear; end else DoPrepareInvalidRects; // descendants should override this method for painting operations, // not the Paint method!!! FBufferValid := True; end; procedure TCustomPaintBox32.DoPaintGDIOverlay; begin if Assigned(FOnGDIOverlay) then FOnGDIOverlay(Self); end; procedure TCustomPaintBox32.Flush; begin if (FBuffer.Handle <> 0) then begin Canvas.Lock; try FBuffer.Lock; try if (Canvas.Handle <> 0) then with GetViewportRect do BitBlt(Canvas.Handle, Left, Top, Right - Left, Bottom - Top, FBuffer.Handle, 0, 0, SRCCOPY); finally FBuffer.Unlock; end; finally Canvas.Unlock; end; end; end; procedure TCustomPaintBox32.Flush(const SrcRect: TRect); var R: TRect; begin if (FBuffer.Handle <> 0) then begin Canvas.Lock; try FBuffer.Lock; try R := GetViewPortRect; if (Canvas.Handle <> 0) then with SrcRect do BitBlt(Canvas.Handle, Left + R.Left, Top + R.Top, Right - Left, Bottom - Top, FBuffer.Handle, Left, Top, SRCCOPY); finally FBuffer.Unlock; end; finally Canvas.Unlock; end; end; end; function TCustomPaintBox32.GetViewportRect: TRect; begin // returns position of the buffered area within the control bounds // by default, the whole control is buffered Result.Left := 0; Result.Top := 0; Result.Right := Width; Result.Bottom := Height; end; procedure TCustomPaintBox32.Invalidate; begin FBufferValid := False; inherited; end; procedure TCustomPaintBox32.ForceFullInvalidate; begin if FRepaintOptimizer.Enabled then FRepaintOptimizer.Reset; FForceFullRepaint := True; Invalidate; end; procedure TCustomPaintBox32.Loaded; begin FBufferValid := False; inherited; end; procedure TCustomPaintBox32.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (pboAutoFocus in Options) and CanFocus then SetFocus; inherited; end; procedure TCustomPaintBox32.MouseEnter; begin FMouseInControl := True; if Assigned(FOnMouseEnter) then FOnMouseEnter(Self); end; procedure TCustomPaintBox32.MouseLeave; begin FMouseInControl := False; if Assigned(FOnMouseLeave) then FOnMouseLeave(Self); end; procedure TCustomPaintBox32.Paint; begin if not Assigned(Parent) then Exit; if FRepaintOptimizer.Enabled then FRepaintOptimizer.BeginPaint; if not FBufferValid then begin (FBuffer.Backend as IPaintSupport).ImageNeeded; DoPaintBuffer; (FBuffer.Backend as IPaintSupport).CheckPixmap; end; FBuffer.Lock; with Canvas do try (FBuffer.Backend as IPaintSupport).DoPaint(FBuffer, FInvalidRects, Canvas, Self); finally FBuffer.Unlock; end; DoPaintGDIOverlay; if FRepaintOptimizer.Enabled then FRepaintOptimizer.EndPaint; ResetInvalidRects; FForceFullRepaint := False; end; procedure TCustomPaintBox32.ResetInvalidRects; begin FInvalidRects.Clear; end; procedure TCustomPaintBox32.Resize; begin ResizeBuffer; BufferValid := False; inherited; end; procedure TCustomPaintBox32.ResizeBuffer; var NewWidth, NewHeight, W, H: Integer; OldWidth, OldHeight: Integer; begin // get the viewport parameters with GetViewportRect do begin NewWidth := Right - Left; NewHeight := Bottom - Top; end; if NewWidth < 0 then NewWidth := 0; if NewHeight < 0 then NewHeight := 0; W := FBuffer.Width; if NewWidth > W then W := NewWidth + FBufferOversize else if NewWidth < W - FBufferOversize then W := NewWidth; if W < 1 then W := 1; H := FBuffer.Height; if NewHeight > H then H := NewHeight + FBufferOversize else if NewHeight < H - FBufferOversize then H := NewHeight; if H < 1 then H := 1; if (W <> FBuffer.Width) or (H <> FBuffer.Height) then begin FBuffer.Lock; OldWidth := Buffer.Width; OldHeight := Buffer.Height; FBuffer.SetSize(W, H); FBuffer.Unlock; DoBufferResized(OldWidth, OldHeight); ForceFullInvalidate; end; end; procedure TCustomPaintBox32.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin inherited; if csDesigning in ComponentState then ResizeBuffer; FBufferValid := False; end; procedure TCustomPaintBox32.SetBufferOversize(Value: Integer); begin if Value < 0 then Value := 0; if Value <> FBufferOversize then begin FBufferOversize := Value; ResizeBuffer; FBufferValid := False end; end; procedure TCustomPaintBox32.WMEraseBkgnd(var Message: {$IFDEF FPC}TLmEraseBkgnd{$ELSE}TWmEraseBkgnd{$ENDIF}); begin Message.Result := 1; end; procedure TCustomPaintBox32.WMGetDlgCode(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TWmGetDlgCode{$ENDIF}); begin with Msg do if pboWantArrowKeys in Options then Result:= Result or DLGC_WANTARROWS else Result:= Result and not DLGC_WANTARROWS; end; procedure TCustomPaintBox32.WMPaint(var Message: {$IFDEF FPC}TLMPaint{$ELSE}TMessage{$ENDIF}); begin if CustomRepaint then begin if InvalidRectsAvailable then // BeginPaint deeper might set invalid clipping, so we call Paint here // to force repaint of our invalid rects... {$IFNDEF FPC} Paint {$ENDIF} else // no invalid rects available? Invalidate the whole client area InvalidateRect(Handle, nil, False); end; {$IFDEF FPC} { On FPC we need to specify the name of the ancestor here } inherited WMPaint(Message); {$ELSE} inherited; {$ENDIF} end; procedure TCustomPaintBox32.DirectAreaUpdateHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); begin FInvalidRects.Add(Area); if not(csCustomPaint in ControlState) then Repaint; end; procedure TCustomPaintBox32.SetRepaintMode(const Value: TRepaintMode); begin if Assigned(FRepaintOptimizer) then begin // setup event handler on change of area if (Value = rmOptimizer) and not(Self is TCustomImage32) then FBuffer.OnAreaChanged := FRepaintOptimizer.AreaUpdateHandler else if Value = rmDirect then FBuffer.OnAreaChanged := DirectAreaUpdateHandler else FBuffer.OnAreaChanged := nil; FRepaintOptimizer.Enabled := Value = rmOptimizer; FRepaintMode := Value; Invalidate; end; end; { TPaintBox32 } procedure TPaintBox32.DoPaintBuffer; begin if Assigned(FOnPaintBuffer) then FOnPaintBuffer(Self); inherited; end; { TCustomImage32 } constructor TCustomImage32.Create(AOwner: TComponent); begin inherited; ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csDoubleClicks, csReplicatable, csOpaque]; FBitmap := TBitmap32.Create; FBitmap.OnResize := BitmapResizeHandler; FLayers := TLayerCollection.Create(Self); with TLayerCollectionAccess(FLayers) do begin OnChange := LayerCollectionChangeHandler; OnGDIUpdate := LayerCollectionGDIUpdateHandler; OnGetViewportScale := LayerCollectionGetViewportScaleHandler; OnGetViewportShift := LayerCollectionGetViewportShiftHandler; end; FRepaintOptimizer.RegisterLayerCollection(FLayers); RepaintMode := rmFull; FPaintStages := TPaintStages.Create; FScaleX := 1; FScaleY := 1; SetXForm(0, 0, 1, 1); InitDefaultStages; end; destructor TCustomImage32.Destroy; begin BeginUpdate; FPaintStages.Free; FRepaintOptimizer.UnregisterLayerCollection(FLayers); FLayers.Free; FBitmap.Free; inherited; end; procedure TCustomImage32.BeginUpdate; begin // disable OnChange & OnChanging generation Inc(FUpdateCount); end; procedure TCustomImage32.BitmapResized; var W, H: Integer; begin if AutoSize then begin W := Bitmap.Width; H := Bitmap.Height; if ScaleMode = smScale then begin W := Round(W * Scale); H := Round(H * Scale); end; if AutoSize and (W > 0) and (H > 0) then SetBounds(Left, Top, W, H); end; if (FUpdateCount = 0) and Assigned(FOnBitmapResize) then FOnBitmapResize(Self); InvalidateCache; ForceFullInvalidate; end; procedure TCustomImage32.BitmapChanged(const Area: TRect); begin Changed; end; function TCustomImage32.BitmapToControl(const APoint: TPoint): TPoint; begin // convert coordinates from bitmap's ref. frame to control's ref. frame UpdateCache; with APoint do begin Result.X := Trunc(X * CachedScaleX + CachedShiftX); Result.Y := Trunc(Y * CachedScaleY + CachedShiftY); end; end; function TCustomImage32.BitmapToControl(const APoint: TFloatPoint): TFloatPoint; begin // subpixel precision version UpdateCache; with APoint do begin Result.X := X * CachedScaleX + CachedShiftX; Result.Y := Y * CachedScaleY + CachedShiftY; end; end; procedure TCustomImage32.BitmapResizeHandler(Sender: TObject); begin BitmapResized; end; procedure TCustomImage32.BitmapChangeHandler(Sender: TObject); begin FRepaintOptimizer.Reset; BitmapChanged(Bitmap.Boundsrect); end; procedure TCustomImage32.BitmapAreaChangeHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); var T, R: TRect; Width, Tx, Ty, I, J: Integer; begin if Sender = FBitmap then begin T := Area; Width := Trunc(FBitmap.Resampler.Width) + 1; InflateArea(T, Width, Width); T.TopLeft := BitmapToControl(T.TopLeft); T.BottomRight := BitmapToControl(T.BottomRight); if FBitmapAlign <> baTile then FRepaintOptimizer.AreaUpdateHandler(Self, T, AREAINFO_RECT) else begin with CachedBitmapRect do begin Tx := Buffer.Width div Right; Ty := Buffer.Height div Bottom; for J := 0 to Ty do for I := 0 to Tx do begin R := T; OffsetRect(R, Right * I, Bottom * J); FRepaintOptimizer.AreaUpdateHandler(Self, R, AREAINFO_RECT); end; end; end; end; BitmapChanged(Area); end; procedure TCustomImage32.BitmapDirectAreaChangeHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); var T, R: TRect; Width, Tx, Ty, I, J: Integer; begin if Sender = FBitmap then begin T := Area; Width := Trunc(FBitmap.Resampler.Width) + 1; InflateArea(T, Width, Width); T.TopLeft := BitmapToControl(T.TopLeft); T.BottomRight := BitmapToControl(T.BottomRight); if FBitmapAlign <> baTile then InvalidRects.Add(T) else begin with CachedBitmapRect do begin Tx := Buffer.Width div Right; Ty := Buffer.Height div Bottom; for J := 0 to Ty do for I := 0 to Tx do begin R := T; OffsetRect(R, Right * I, Bottom * J); InvalidRects.Add(R); end; end; end; end; if FUpdateCount = 0 then begin if not(csCustomPaint in ControlState) then Repaint; if Assigned(FOnChange) then FOnChange(Self); end; end; function TCustomImage32.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; var W, H: Integer; begin InvalidateCache; Result := True; W := Bitmap.Width; H := Bitmap.Height; if ScaleMode = smScale then begin W := Round(W * Scale); H := Round(H * Scale); end; if not (csDesigning in ComponentState) or (W > 0) and (H > 0) then begin if Align in [alNone, alLeft, alRight] then NewWidth := W; if Align in [alNone, alTop, alBottom] then NewHeight := H; end; end; procedure TCustomImage32.Changed; begin if FUpdateCount = 0 then begin Invalidate; if Assigned(FOnChange) then FOnChange(Self); end; end; function TCustomImage32.ControlToBitmap(const APoint: TPoint): TPoint; begin // convert point coords from control's ref. frame to bitmap's ref. frame // the coordinates are not clipped to bitmap image boundary UpdateCache; with APoint do begin if (CachedRecScaleX = 0) then Result.X := High(Result.X) else Result.X := Floor((X - CachedShiftX) * CachedRecScaleX); if (CachedRecScaleY = 0) then Result.Y := High(Result.Y) else Result.Y := Floor((Y - CachedShiftY) * CachedRecScaleY); end; end; function TCustomImage32.ControlToBitmap(const APoint: TFloatPoint): TFloatPoint; begin // subpixel precision version UpdateCache; with APoint do begin if (CachedRecScaleX = 0) then Result.X := MaxInt else Result.X := (X - CachedShiftX) * CachedRecScaleX; if (CachedRecScaleY = 0) then Result.Y := MaxInt else Result.Y := (Y - CachedShiftY) * CachedRecScaleY; end; end; procedure TCustomImage32.DoInitStages; begin if Assigned(FOnInitStages) then FOnInitStages(Self); end; procedure TCustomImage32.DoPaintBuffer; var PaintStageHandlerCount: Integer; I, J: Integer; DT, RT: Boolean; begin if FRepaintOptimizer.Enabled then FRepaintOptimizer.BeginPaintBuffer; UpdateCache; SetLength(FPaintStageHandlers, FPaintStages.Count); SetLength(FPaintStageNum, FPaintStages.Count); PaintStageHandlerCount := 0; DT := csDesigning in ComponentState; RT := not DT; // compile list of paintstage handler methods for I := 0 to FPaintStages.Count - 1 do begin with FPaintStages[I]^ do if (DsgnTime and DT) or (RunTime and RT) then begin FPaintStageNum[PaintStageHandlerCount] := I; case Stage of PST_CUSTOM: FPaintStageHandlers[PaintStageHandlerCount] := ExecCustom; PST_CLEAR_BUFFER: FPaintStageHandlers[PaintStageHandlerCount] := ExecClearBuffer; PST_CLEAR_BACKGND: FPaintStageHandlers[PaintStageHandlerCount] := ExecClearBackgnd; PST_DRAW_BITMAP: FPaintStageHandlers[PaintStageHandlerCount] := ExecDrawBitmap; PST_DRAW_LAYERS: FPaintStageHandlers[PaintStageHandlerCount] := ExecDrawLayers; PST_CONTROL_FRAME: FPaintStageHandlers[PaintStageHandlerCount] := ExecControlFrame; PST_BITMAP_FRAME: FPaintStageHandlers[PaintStageHandlerCount] := ExecBitmapFrame; else Dec(PaintStageHandlerCount); // this should not happen . end; Inc(PaintStageHandlerCount); end; end; Buffer.BeginUpdate; if FInvalidRects.Count = 0 then begin Buffer.ClipRect := GetViewportRect; for I := 0 to PaintStageHandlerCount - 1 do FPaintStageHandlers[I](Buffer, FPaintStageNum[I]); end else begin for J := 0 to FInvalidRects.Count - 1 do begin Buffer.ClipRect := FInvalidRects[J]^; for I := 0 to PaintStageHandlerCount - 1 do FPaintStageHandlers[I](Buffer, FPaintStageNum[I]); end; Buffer.ClipRect := GetViewportRect; end; Buffer.EndUpdate; if FRepaintOptimizer.Enabled then FRepaintOptimizer.EndPaintBuffer; // avoid calling inherited, we have a totally different behaviour here... FBufferValid := True; end; procedure TCustomImage32.DoPaintGDIOverlay; var I: Integer; begin for I := 0 to Layers.Count - 1 do if (Layers[I].LayerOptions and LOB_GDI_OVERLAY) <> 0 then TLayerAccess(Layers[I]).PaintGDI(Canvas); inherited; end; procedure TCustomImage32.DoScaleChange; begin if Assigned(FOnScaleChange) then FOnScaleChange(Self); end; procedure TCustomImage32.EndUpdate; begin // re-enable OnChange & OnChanging generation Dec(FUpdateCount); Assert(FUpdateCount >= 0, 'Unpaired EndUpdate call'); end; procedure TCustomImage32.ExecBitmapFrame(Dest: TBitmap32; StageNum: Integer); begin Dest.Canvas.DrawFocusRect(CachedBitmapRect); end; procedure TCustomImage32.ExecClearBackgnd(Dest: TBitmap32; StageNum: Integer); var C: TColor32; I: Integer; begin C := Color32(Color); if FInvalidRects.Count > 0 then begin for I := 0 to FInvalidRects.Count - 1 do with FInvalidRects[I]^ do Dest.FillRectS(Left, Top, Right, Bottom, C); end else begin if ((Bitmap.Empty) or (Bitmap.DrawMode <> dmOpaque)) and assigned(Dest) then Dest.Clear(C) else with CachedBitmapRect do begin if (Left > 0) or (Right < Self.Width) or (Top > 0) or (Bottom < Self.Height) and not (BitmapAlign = baTile) then begin // clean only the part of the buffer lying around image edges Dest.FillRectS(0, 0, Self.Width, Top, C); // top Dest.FillRectS(0, Bottom, Self.Width, Self.Height, C); // bottom Dest.FillRectS(0, Top, Left, Bottom, C); // left Dest.FillRectS(Right, Top, Self.Width, Bottom, C); // right end; end; end; end; procedure TCustomImage32.ExecClearBuffer(Dest: TBitmap32; StageNum: Integer); begin Dest.Clear(Color32(Color)); end; procedure TCustomImage32.ExecControlFrame(Dest: TBitmap32; StageNum: Integer); begin DrawFocusRect(Dest.Handle, Rect(0, 0, Width, Height)); end; procedure TCustomImage32.ExecCustom(Dest: TBitmap32; StageNum: Integer); begin if Assigned(FOnPaintStage) then FOnPaintStage(Self, Dest, StageNum); end; procedure TCustomImage32.ExecDrawBitmap(Dest: TBitmap32; StageNum: Integer); var I, J, Tx, Ty: Integer; R: TRect; begin if Bitmap.Empty or IsRectEmpty(CachedBitmapRect) then Exit; Bitmap.Lock; try if BitmapAlign <> baTile then Bitmap.DrawTo(Dest, CachedBitmapRect) else with CachedBitmapRect do begin Tx := Dest.Width div Right; Ty := Dest.Height div Bottom; for J := 0 to Ty do for I := 0 to Tx do begin R := CachedBitmapRect; OffsetRect(R, Right * I, Bottom * J); Bitmap.DrawTo(Dest, R); end; end; finally Bitmap.Unlock; end; end; procedure TCustomImage32.ExecDrawLayers(Dest: TBitmap32; StageNum: Integer); var I: Integer; Mask: Cardinal; begin Mask := PaintStages[StageNum]^.Parameter; for I := 0 to Layers.Count - 1 do if (Layers.Items[I].LayerOptions and Mask) <> 0 then TLayerAccess(Layers.Items[I]).DoPaint(Dest); end; function TCustomImage32.GetBitmapRect: TRect; var Size: TSize; begin if Bitmap.Empty then with Result do begin Left := 0; Right := 0; Top := 0; Bottom := 0; end else begin Size := GetBitmapSize; Result := Rect(0, 0, Size.Cx, Size.Cy); if BitmapAlign = baCenter then OffsetRect(Result, (Width - Size.Cx) div 2, (Height - Size.Cy) div 2) else if BitmapAlign = baCustom then OffsetRect(Result, Round(OffsetHorz), Round(OffsetVert)); end; end; function TCustomImage32.GetBitmapSize: TSize; var Mode: TScaleMode; ViewportWidth, ViewportHeight: Integer; RScaleX, RScaleY: TFloat; begin // with Result do begin if Bitmap.Empty or (Width = 0) or (Height = 0) then begin Result.Cx := 0; Result.Cy := 0; Exit; end; with GetViewportRect do begin ViewportWidth := Right - Left; ViewportHeight := Bottom - Top; end; // check for optimal modes as these are compounds of the other modes. case ScaleMode of smOptimal: if (Bitmap.Width > ViewportWidth) or (Bitmap.Height > ViewportHeight) then Mode := smResize else Mode := smNormal; smOptimalScaled: if (Round(Bitmap.Width * ScaleX) > ViewportWidth) or (Round(Bitmap.Height * ScaleY) > ViewportHeight) then Mode := smResize else Mode := smScale; else Mode := ScaleMode; end; case Mode of smNormal: begin Result.Cx := Bitmap.Width; Result.Cy := Bitmap.Height; end; smStretch: begin Result.Cx := ViewportWidth; Result.Cy := ViewportHeight; end; smResize: begin Result.Cx := Bitmap.Width; Result.Cy := Bitmap.Height; RScaleX := ViewportWidth / Result.Cx; RScaleY := ViewportHeight / Result.Cy; if RScaleX >= RScaleY then begin Result.Cx := Round(Result.Cx * RScaleY); Result.Cy := ViewportHeight; end else begin Result.Cx := ViewportWidth; Result.Cy := Round(Result.Cy * RScaleX); end; end; else // smScale begin Result.Cx := Round(Bitmap.Width * ScaleX); Result.Cy := Round(Bitmap.Height * ScaleY); end; end; if Result.Cx <= 0 then Result.Cx := 0; if Result.Cy <= 0 then Result.Cy := 0; end; end; function TCustomImage32.GetOnPixelCombine: TPixelCombineEvent; begin Result := FBitmap.OnPixelCombine; end; procedure TCustomImage32.InitDefaultStages; begin // background with PaintStages.Add^ do begin DsgnTime := True; RunTime := True; Stage := PST_CLEAR_BACKGND; end; // control frame with PaintStages.Add^ do begin DsgnTime := True; RunTime := False; Stage := PST_CONTROL_FRAME; end; // bitmap with PaintStages.Add^ do begin DsgnTime := True; RunTime := True; Stage := PST_DRAW_BITMAP; end; // bitmap frame with PaintStages.Add^ do begin DsgnTime := True; RunTime := False; Stage := PST_BITMAP_FRAME; end; // layers with PaintStages.Add^ do begin DsgnTime := True; RunTime := True; Stage := PST_DRAW_LAYERS; Parameter := LOB_VISIBLE; end; end; procedure TCustomImage32.Invalidate; begin BufferValid := False; CacheValid := False; inherited; end; procedure TCustomImage32.InvalidateCache; begin if FRepaintOptimizer.Enabled and CacheValid then FRepaintOptimizer.Reset; CacheValid := False; end; function TCustomImage32.InvalidRectsAvailable: Boolean; begin // avoid calling inherited, we have a totally different behaviour here... DoPrepareInvalidRects; Result := FInvalidRects.Count > 0; end; procedure TCustomImage32.LayerCollectionChangeHandler(Sender: TObject); begin Changed; end; procedure TCustomImage32.LayerCollectionGDIUpdateHandler(Sender: TObject); begin Paint; end; procedure TCustomImage32.LayerCollectionGetViewportScaleHandler(Sender: TObject; out ScaleX, ScaleY: TFloat); begin UpdateCache; ScaleX := CachedScaleX; ScaleY := CachedScaleY; end; procedure TCustomImage32.LayerCollectionGetViewportShiftHandler(Sender: TObject; out ShiftX, ShiftY: TFloat); begin UpdateCache; ShiftX := CachedShiftX; ShiftY := CachedShiftY; end; procedure TCustomImage32.Loaded; begin inherited; DoInitStages; end; procedure TCustomImage32.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Layer: TCustomLayer; begin inherited; if TabStop and CanFocus then SetFocus; if Layers.MouseEvents then Layer := TLayerCollectionAccess(Layers).MouseDown(Button, Shift, X, Y) else Layer := nil; // lock the capture only if mbLeft was pushed or any mouse listener was activated if (Button = mbLeft) or (TLayerCollectionAccess(Layers).MouseListener <> nil) then MouseCapture := True; MouseDown(Button, Shift, X, Y, Layer); end; procedure TCustomImage32.MouseMove(Shift: TShiftState; X, Y: Integer); var Layer: TCustomLayer; begin inherited; if Layers.MouseEvents then Layer := TLayerCollectionAccess(Layers).MouseMove(Shift, X, Y) else Layer := nil; MouseMove(Shift, X, Y, Layer); end; procedure TCustomImage32.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Layer: TCustomLayer; begin if Layers.MouseEvents then Layer := TLayerCollectionAccess(Layers).MouseUp(Button, Shift, X, Y) else Layer := nil; // unlock the capture using same criteria as was used to acquire it if (Button = mbLeft) or (TLayerCollectionAccess(Layers).MouseListener <> nil) then MouseCapture := False; MouseUp(Button, Shift, X, Y, Layer); end; procedure TCustomImage32.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); begin if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y, Layer); end; procedure TCustomImage32.MouseMove(Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); begin if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y, Layer); end; procedure TCustomImage32.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); begin if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y, Layer); end; procedure TCustomImage32.MouseLeave; begin if (Layers.MouseEvents) and (Layers.MouseListener = nil) then Screen.Cursor := crDefault; inherited; end; procedure TCustomImage32.PaintTo(Dest: TBitmap32; DestRect: TRect); var OldRepaintMode: TRepaintMode; I: Integer; begin if not assigned(Dest)then exit; OldRepaintMode := RepaintMode; RepaintMode := rmFull; CachedBitmapRect := DestRect; with CachedBitmapRect do begin if (Right - Left <= 0) or (Bottom - Top <= 0) or Bitmap.Empty then SetXForm(0, 0, 1, 1) else SetXForm(Left, Top, (Right - Left) / Bitmap.Width, (Bottom - Top) / Bitmap.Height); end; CacheValid := True; PaintToMode := True; try for I := 0 to FPaintStages.Count - 1 do with FPaintStages[I]^ do if RunTime then case Stage of PST_CUSTOM: ExecCustom(Dest, I); PST_CLEAR_BUFFER: ExecClearBuffer(Dest, I); PST_CLEAR_BACKGND: ExecClearBackgnd(Dest, I); PST_DRAW_BITMAP: ExecDrawBitmap(Dest, I); PST_DRAW_LAYERS: ExecDrawLayers(Dest, I); PST_CONTROL_FRAME: ExecControlFrame(Dest, I); PST_BITMAP_FRAME: ExecBitmapFrame(Dest, I); end; finally PaintToMode := False; end; CacheValid := False; RepaintMode := OldRepaintMode; end; procedure TCustomImage32.Resize; begin InvalidateCache; inherited; end; procedure TCustomImage32.SetBitmap(Value: TBitmap32); begin InvalidateCache; FBitmap.Assign(Value); end; procedure TCustomImage32.SetBitmapAlign(Value: TBitmapAlign); begin InvalidateCache; FBitmapAlign := Value; Changed; end; procedure TCustomImage32.SetLayers(Value: TLayerCollection); begin FLayers.Assign(Value); end; procedure TCustomImage32.SetOffsetHorz(Value: TFloat); begin if Value <> FOffsetHorz then begin InvalidateCache; FOffsetHorz := Value; Changed; end; end; procedure TCustomImage32.SetOffsetVert(Value: TFloat); begin if Value <> FOffsetVert then begin FOffsetVert := Value; InvalidateCache; Changed; end; end; procedure TCustomImage32.SetOnPixelCombine(Value: TPixelCombineEvent); begin FBitmap.OnPixelCombine := Value; Changed; end; procedure TCustomImage32.SetScale(Value: TFloat); begin if Value < 0.001 then Value := 0.001; if Value <> FScaleX then begin InvalidateCache; FScaleX := Value; FScaleY := Value; CachedScaleX := FScaleX; CachedScaleY := FScaleY; CachedRecScaleX := 1 / Value; CachedRecScaleY := 1 / Value; DoScaleChange; Changed; end; end; procedure TCustomImage32.SetScaleX(Value: TFloat); begin if Value < 0.001 then Value := 0.001; if Value <> FScaleX then begin InvalidateCache; FScaleX := Value; CachedScaleX := Value; CachedRecScaleX := 1 / Value; DoScaleChange; Changed; end; end; procedure TCustomImage32.SetScaleY(Value: TFloat); begin if Value < 0.001 then Value := 0.001; if Value <> FScaleY then begin InvalidateCache; FScaleY := Value; CachedScaleY := Value; CachedRecScaleY := 1 / Value; DoScaleChange; Changed; end; end; procedure TCustomImage32.SetScaleMode(Value: TScaleMode); begin if Value <> FScaleMode then begin InvalidateCache; FScaleMode := Value; Changed; end; end; procedure TCustomImage32.SetupBitmap(DoClear: Boolean = False; ClearColor: TColor32 = $FF000000); begin FBitmap.BeginUpdate; with GetViewPortRect do FBitmap.SetSize(Right - Left, Bottom - Top); if DoClear then FBitmap.Clear(ClearColor); FBitmap.EndUpdate; InvalidateCache; Changed; end; procedure TCustomImage32.SetXForm(ShiftX, ShiftY, ScaleX, ScaleY: TFloat); begin CachedShiftX := ShiftX; CachedShiftY := ShiftY; CachedScaleX := ScaleX; CachedScaleY := ScaleY; if (ScaleX <> 0) then CachedRecScaleX := 1 / ScaleX else CachedRecScaleX := 0; if (ScaleY <> 0) then CachedRecScaleY := 1 / ScaleY else CachedRecScaleY := 0; end; procedure TCustomImage32.SetRepaintMode(const Value: TRepaintMode); begin inherited; case Value of rmOptimizer: begin FBitmap.OnAreaChanged := BitmapAreaChangeHandler; FBitmap.OnChange := nil; end; rmDirect: begin FBitmap.OnAreaChanged := BitmapDirectAreaChangeHandler; FBitmap.OnChange := nil; end; else FBitmap.OnAreaChanged := nil; FBitmap.OnChange := BitmapChangeHandler; end; end; procedure TCustomImage32.Update(const Rect: TRect); begin if FRepaintOptimizer.Enabled then FRepaintOptimizer.AreaUpdateHandler(Self, Rect, AREAINFO_RECT); end; procedure TCustomImage32.UpdateCache; begin if CacheValid then Exit; CachedBitmapRect := GetBitmapRect; if Bitmap.Empty then SetXForm(0, 0, 1, 1) else SetXForm( CachedBitmapRect.Left, CachedBitmapRect.Top, (CachedBitmapRect.Right - CachedBitmapRect.Left) / Bitmap.Width, (CachedBitmapRect.Bottom - CachedBitmapRect.Top) / Bitmap.Height ); CacheValid := True; end; { TIVScrollProperties } function TIVScrollProperties.GetIncrement: Integer; begin Result := Round(TCustomRangeBar(Master).Increment); end; function TIVScrollProperties.GetSize: Integer; begin Result := ImgView.FScrollBarSize; end; function TIVScrollProperties.GetVisibility: TScrollbarVisibility; begin Result := ImgView.FScrollBarVisibility; end; procedure TIVScrollProperties.SetIncrement(Value: Integer); begin TCustomRangeBar(Master).Increment := Value; TCustomRangeBar(Slave).Increment := Value; end; procedure TIVScrollProperties.SetSize(Value: Integer); begin ImgView.FScrollBarSize := Value; ImgView.AlignAll; ImgView.UpdateImage; end; procedure TIVScrollProperties.SetVisibility(const Value: TScrollbarVisibility); begin if Value <> ImgView.FScrollBarVisibility then begin ImgView.FScrollBarVisibility := Value; ImgView.Resize; end; end; { TCustomImgView32 } procedure TCustomImgView32.AlignAll; var ScrollbarVisible: Boolean; begin if (Width > 0) and (Height > 0) then with GetViewportRect do begin ScrollbarVisible := GetScrollBarsVisible; if Assigned(HScroll) then begin HScroll.BoundsRect := Rect(Left, Bottom, Right, Self.Height); HScroll.Visible := ScrollbarVisible; HScroll.Repaint; end; if Assigned(VScroll) then begin VScroll.BoundsRect := Rect(Right, Top, Self.Width, Bottom); VScroll.Visible := ScrollbarVisible; VScroll.Repaint; end; end; end; procedure TCustomImgView32.BitmapResized; begin inherited; UpdateScrollBars; if Centered then ScrollToCenter(Bitmap.Width div 2, Bitmap.Height div 2) else begin HScroll.Position := 0; VScroll.Position := 0; UpdateImage; end; end; constructor TCustomImgView32.Create(AOwner: TComponent); begin inherited; FScrollBarSize := GetSystemMetrics(SM_CYHSCROLL); HScroll := TCustomRangeBar.Create(Self); VScroll := TCustomRangeBar.Create(Self); with HScroll do begin HScroll.Parent := Self; BorderStyle := bsNone; Centered := True; OnUserChange := ScrollHandler; end; with VScroll do begin Parent := Self; BorderStyle := bsNone; Centered := True; Kind := sbVertical; OnUserChange := ScrollHandler; end; FCentered := True; ScaleMode := smScale; BitmapAlign := baCustom; with GetViewportRect do begin OldSzX := Right - Left; OldSzY := Bottom - Top; end; FScrollBars := TIVScrollProperties.Create; FScrollBars.ImgView := Self; FScrollBars.Master := HScroll; FScrollBars.Slave := VScroll; AlignAll; end; destructor TCustomImgView32.Destroy; begin FreeAndNil(FScrollBars); inherited; end; procedure TCustomImgView32.DoDrawSizeGrip(R: TRect); begin {$IFDEF Windows} if USE_THEMES then begin Canvas.Brush.Color := clBtnFace; Canvas.FillRect(R); DrawThemeBackground(SCROLLBAR_THEME, Canvas.Handle, SBP_SIZEBOX, SZB_RIGHTALIGN, R, nil); end else DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, DFCS_SCROLLSIZEGRIP) {$ENDIF} end; procedure TCustomImgView32.DoScaleChange; begin inherited; InvalidateCache; UpdateScrollBars; UpdateImage; Invalidate; end; procedure TCustomImgView32.DoScroll; begin if Assigned(FOnScroll) then FOnScroll(Self); end; function TCustomImgView32.GetScrollBarSize: Integer; begin if GetScrollBarsVisible then begin Result := FScrollBarSize; if Result = 0 then Result := GetSystemMetrics(SM_CYHSCROLL); end else Result := 0; end; function TCustomImgView32.GetScrollBarsVisible: Boolean; begin Result := True; if Assigned(FScrollBars) and Assigned(HScroll) and Assigned(VScroll) then case FScrollBars.Visibility of svAlways: Result := True; svHidden: Result := False; svAuto: Result := (HScroll.Range > (TRangeBarAccess(HScroll).EffectiveWindow + VScroll.Width)) or (VScroll.Range > (TRangeBarAccess(VScroll).EffectiveWindow + HScroll.Height)); end; end; function TCustomImgView32.GetSizeGripRect: TRect; var Sz: Integer; begin Sz := GetScrollBarSize; if not Assigned(Parent) then Result := BoundsRect else Result := ClientRect; with Result do begin Left := Right - Sz; Top := Bottom - Sz; end; end; function TCustomImgView32.GetViewportRect: TRect; var Sz: Integer; begin Result := Rect(0, 0, Width, Height); Sz := GetScrollBarSize; Dec(Result.Right, Sz); Dec(Result.Bottom, Sz); end; function TCustomImgView32.IsSizeGripVisible: Boolean; var P: TWinControl; begin case SizeGrip of sgAuto: begin Result := False; if Align <> alClient then Exit; P := Parent; while True do begin if P is TCustomForm then begin Result := True; Break; end else if not Assigned(P) or (P.Align <> alClient) then Exit; P := P.Parent; end; end; sgNone: Result := False else { sgAlways } Result := True; end; end; procedure TCustomImgView32.Loaded; begin AlignAll; Invalidate; UpdateScrollBars; if Centered then with Bitmap do ScrollToCenter(Width div 2, Height div 2); inherited; end; procedure TCustomImgView32.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); {$IFNDEF PLATFORM_INDEPENDENT} var Action: Cardinal; Msg: TMessage; P: TPoint; {$ENDIF} begin {$IFNDEF PLATFORM_INDEPENDENT} if IsSizeGripVisible and (Owner is TCustomForm) then begin P.X := X; P.Y := Y; if PtInRect(GetSizeGripRect, P) then begin Action := HTBOTTOMRIGHT; Application.ProcessMessages; Msg.Msg := WM_NCLBUTTONDOWN; Msg.WParam := Action; SetCaptureControl(nil); with Msg do SendMessage(TCustomForm(Owner).Handle, Msg, wParam, lParam); Exit; end; end; {$ENDIF} inherited; end; procedure TCustomImgView32.MouseMove(Shift: TShiftState; X, Y: Integer); var P: TPoint; begin inherited; if IsSizeGripVisible then begin P.X := X; P.Y := Y; if PtInRect(GetSizeGripRect, P) then Screen.Cursor := crSizeNWSE; end; end; procedure TCustomImgView32.Paint; begin if not Assigned(Parent) then Exit; if IsSizeGripVisible then DoDrawSizeGrip(GetSizeGripRect) else begin Canvas.Brush.Color := clBtnFace; Canvas.FillRect(GetSizeGripRect); end; inherited; end; procedure TCustomImgView32.Resize; begin AlignAll; if Assigned(Parent) then begin if IsSizeGripVisible then DoDrawSizeGrip(GetSizeGripRect) else begin Canvas.Brush.Color := clBtnFace; Canvas.FillRect(GetSizeGripRect); end; end; InvalidateCache; UpdateScrollBars; UpdateImage; Invalidate; inherited; end; procedure TCustomImgView32.Scroll(Dx, Dy: Integer); begin DisableScrollUpdate := True; HScroll.Position := HScroll.Position + Dx; VScroll.Position := VScroll.Position + Dy; DisableScrollUpdate := False; UpdateImage; end; procedure TCustomImgView32.ScrollHandler(Sender: TObject); begin if DisableScrollUpdate then Exit; if Sender = HScroll then HScroll.Repaint; if Sender = VScroll then VScroll.Repaint; UpdateImage; DoScroll; Repaint; end; procedure TCustomImgView32.ScrollToCenter(X, Y: Integer); var ScaledDOversize: Integer; begin DisableScrollUpdate := True; AlignAll; ScaledDOversize := Round(FOversize * Scale); with GetViewportRect do begin HScroll.Position := X * Scale - (Right - Left) * 0.5 + ScaledDOversize; VScroll.Position := Y * Scale - (Bottom - Top) * 0.5 + ScaledDOversize; end; DisableScrollUpdate := False; UpdateImage; end; procedure TCustomImgView32.Recenter; begin InvalidateCache; HScroll.Centered := FCentered; VScroll.Centered := FCentered; UpdateScrollBars; UpdateImage; if FCentered then with Bitmap do ScrollToCenter(Width div 2, Height div 2) else ScrollToCenter(0, 0); end; procedure TCustomImgView32.SetCentered(Value: Boolean); begin FCentered := Value; Recenter; end; procedure TCustomImgView32.SetOverSize(const Value: Integer); begin if Value <> FOverSize then begin FOverSize := Value; Invalidate; end; end; procedure TCustomImgView32.SetScrollBars(Value: TIVScrollProperties); begin FScrollBars.Assign(Value); end; procedure TCustomImgView32.SetSizeGrip(Value: TSizeGripStyle); begin if Value <> FSizeGrip then begin FSizeGrip := Value; Invalidate; end; end; procedure TCustomImgView32.UpdateImage; var Sz: TSize; W, H: Integer; ScaledOversize: Integer; begin Sz := GetBitmapSize; ScaledOversize := Round(FOversize * Scale); with GetViewportRect do begin W := Right - Left; H := Bottom - Top; end; BeginUpdate; if not Centered then begin OffsetHorz := -HScroll.Position + ScaledOversize; OffsetVert := -VScroll.Position + ScaledOversize; end else begin if W > Sz.Cx + 2 * ScaledOversize then // Viewport is bigger than scaled Bitmap OffsetHorz := (W - Sz.Cx) * 0.5 else OffsetHorz := -HScroll.Position + ScaledOversize; if H > Sz.Cy + 2 * ScaledOversize then // Viewport is bigger than scaled Bitmap OffsetVert := (H - Sz.Cy) * 0.5 else OffsetVert := -VScroll.Position + ScaledOversize; end; InvalidateCache; EndUpdate; Changed; end; procedure TCustomImgView32.UpdateScrollBars; var Sz: TSize; ScaledDOversize: Integer; begin if Assigned(HScroll) and Assigned(VScroll) then begin Sz := GetBitmapSize; ScaledDOversize := Round(2 * FOversize * Scale); HScroll.Range := Sz.Cx + ScaledDOversize; VScroll.Range := Sz.Cy + ScaledDOversize; // call AlignAll for Visibility svAuto, because the ranges of the scrollbars // may have just changed, thus we need to update the visibility of the scrollbars: if FScrollBarVisibility = svAuto then AlignAll; end; end; procedure TCustomImgView32.SetScaleMode(Value: TScaleMode); begin inherited; Recenter; end; { TBitmap32Item } procedure TBitmap32Item.AssignTo(Dest: TPersistent); begin if Dest is TBitmap32Item then TBitmap32Item(Dest).Bitmap.Assign(Bitmap) else inherited; end; constructor TBitmap32Item.Create(Collection: TCollection); begin inherited; FBitmap := TBitmap32.Create; end; destructor TBitmap32Item.Destroy; begin FBitmap.Free; inherited; end; procedure TBitmap32Item.SetBitmap(ABitmap: TBitmap32); begin FBitmap.Assign(ABitmap) end; { TBitmap32Collection } function TBitmap32Collection.Add: TBitmap32Item; begin Result := TBitmap32Item(inherited Add); end; constructor TBitmap32Collection.Create(AOwner: TPersistent; ItemClass: TBitmap32ItemClass); begin inherited Create(ItemClass); FOwner := AOwner; end; function TBitmap32Collection.GetItem(Index: Integer): TBitmap32Item; begin Result := TBitmap32Item(inherited GetItem(Index)); end; function TBitmap32Collection.GetOwner: TPersistent; begin Result := FOwner; end; procedure TBitmap32Collection.SetItem(Index: Integer; Value: TBitmap32Item); begin inherited SetItem(Index, Value); end; { TBitmap32List } constructor TBitmap32List.Create(AOwner: TComponent); begin inherited; FBitmap32Collection := TBitmap32Collection.Create(Self, TBitmap32Item); end; destructor TBitmap32List.Destroy; begin FBitmap32Collection.Free; inherited; end; function TBitmap32List.GetBitmap(Index: Integer): TBitmap32; begin Result := FBitmap32Collection.Items[Index].Bitmap; end; procedure TBitmap32List.SetBitmap(Index: Integer; Value: TBitmap32); begin FBitmap32Collection.Items[Index].Bitmap := Value; end; procedure TBitmap32List.SetBitmap32Collection(Value: TBitmap32Collection); begin FBitmap32Collection := Value; end; end. |
Added src/graphics32/GR32_Layers.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 | unit GR32_Layers; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Andre Beckedorf <Andre@metaException.de> * Michael Hansen <dyster_tid@hotmail.com> * Dieter Köhler <dieter.koehler@philo.de> * * ***** END LICENSE BLOCK ***** *) interface {$INCLUDE GR32.inc} uses {$IFDEF FPC} Controls, Graphics, Forms, {$ELSE} Windows, Controls, Graphics, Forms, {$ENDIF} Classes, SysUtils, Math, GR32; const { Layer Options Bits } LOB_VISIBLE = $80000000; // 31-st bit LOB_GDI_OVERLAY = $40000000; // 30-th bit LOB_MOUSE_EVENTS = $20000000; // 29-th bit LOB_NO_UPDATE = $10000000; // 28-th bit LOB_NO_CAPTURE = $08000000; // 27-th bit LOB_INVALID = $04000000; // 26-th bit LOB_FORCE_UPDATE = $02000000; // 25-th bit LOB_RESERVED_24 = $01000000; // 24-th bit LOB_RESERVED_MASK = $FF000000; type TCustomLayer = class; TPositionedLayer = class; TRubberbandLayer = class; TLayerClass = class of TCustomLayer; TLayerCollection = class; TLayerUpdateEvent = procedure(Sender: TObject; Layer: TCustomLayer) of object; TAreaUpdateEvent = TAreaChangedEvent; TLayerListNotification = (lnLayerAdded, lnLayerInserted, lnLayerDeleted, lnCleared); TLayerListNotifyEvent = procedure(Sender: TLayerCollection; Action: TLayerListNotification; Layer: TCustomLayer; Index: Integer) of object; TGetScaleEvent = procedure(Sender: TObject; out ScaleX, ScaleY: TFloat) of object; TGetShiftEvent = procedure(Sender: TObject; out ShiftX, ShiftY: TFloat) of object; TLayerCollection = class(TPersistent) private FItems: TList; FMouseEvents: Boolean; FMouseListener: TCustomLayer; FUpdateCount: Integer; FOwner: TPersistent; FOnChanging: TNotifyEvent; FOnChange: TNotifyEvent; FOnGDIUpdate: TNotifyEvent; FOnListNotify: TLayerListNotifyEvent; FOnLayerUpdated: TLayerUpdateEvent; FOnAreaUpdated: TAreaUpdateEvent; FOnGetViewportScale: TGetScaleEvent; FOnGetViewportShift: TGetShiftEvent; function GetCount: Integer; procedure InsertItem(Item: TCustomLayer); procedure RemoveItem(Item: TCustomLayer); procedure SetMouseEvents(Value: Boolean); procedure SetMouseListener(Value: TCustomLayer); protected procedure BeginUpdate; procedure Changed; procedure Changing; procedure EndUpdate; function FindLayerAtPos(X, Y: Integer; OptionsMask: Cardinal): TCustomLayer; function GetItem(Index: Integer): TCustomLayer; function GetOwner: TPersistent; override; procedure GDIUpdate; procedure DoUpdateLayer(Layer: TCustomLayer); procedure DoUpdateArea(const Rect: TRect); procedure Notify(Action: TLayerListNotification; Layer: TCustomLayer; Index: Integer); procedure SetItem(Index: Integer; Value: TCustomLayer); function MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): TCustomLayer; function MouseMove(Shift: TShiftState; X, Y: Integer): TCustomLayer; function MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): TCustomLayer; property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnListNotify: TLayerListNotifyEvent read FOnListNotify write FOnListNotify; property OnGDIUpdate: TNotifyEvent read FOnGDIUpdate write FOnGDIUpdate; property OnLayerUpdated: TLayerUpdateEvent read FOnLayerUpdated write FOnLayerUpdated; property OnAreaUpdated: TAreaUpdateEvent read FOnAreaUpdated write FOnAreaUpdated; property OnGetViewportScale: TGetScaleEvent read FOnGetViewportScale write FOnGetViewportScale; property OnGetViewportShift: TGetShiftEvent read FOnGetViewportShift write FOnGetViewportShift; public constructor Create(AOwner: TPersistent); destructor Destroy; override; function Add(ItemClass: TLayerClass): TCustomLayer; procedure Assign(Source: TPersistent); override; procedure Clear; procedure Delete(Index: Integer); function Insert(Index: Integer; ItemClass: TLayerClass): TCustomLayer; function LocalToViewport(const APoint: TFloatPoint; AScaled: Boolean): TFloatPoint; function ViewportToLocal(const APoint: TFloatPoint; AScaled: Boolean): TFloatPoint; procedure GetViewportScale(out ScaleX, ScaleY: TFloat); virtual; procedure GetViewportShift(out ShiftX, ShiftY: TFloat); virtual; property Count: Integer read GetCount; property Owner: TPersistent read FOwner; property Items[Index: Integer]: TCustomLayer read GetItem write SetItem; default; property MouseListener: TCustomLayer read FMouseListener write SetMouseListener; property MouseEvents: Boolean read FMouseEvents write SetMouseEvents; end; {$IFDEF COMPILER2009_UP} TLayerEnum = class private FIndex: Integer; FLayerCollection: TLayerCollection; public constructor Create(ALayerCollection: TLayerCollection); function GetCurrent: TCustomLayer; function MoveNext: Boolean; property Current: TCustomLayer read GetCurrent; end; TLayerCollectionHelper = class Helper for TLayerCollection public function GetEnumerator: TLayerEnum; end; {$ENDIF} TLayerState = (lsMouseLeft, lsMouseRight, lsMouseMiddle); TLayerStates = set of TLayerState; TPaintLayerEvent = procedure(Sender: TObject; Buffer: TBitmap32) of object; THitTestEvent = procedure(Sender: TObject; X, Y: Integer; var Passed: Boolean) of object; TCustomLayer = class(TNotifiablePersistent) private FCursor: TCursor; FFreeNotifies: TList; FLayerCollection: TLayerCollection; FLayerStates: TLayerStates; FLayerOptions: Cardinal; FTag: Integer; FClicked: Boolean; FOnHitTest: THitTestEvent; FOnMouseDown: TMouseEvent; FOnMouseMove: TMouseMoveEvent; FOnMouseUp: TMouseEvent; FOnPaint: TPaintLayerEvent; FOnDestroy: TNotifyEvent; FOnDblClick: TNotifyEvent; FOnClick: TNotifyEvent; function GetIndex: Integer; function GetMouseEvents: Boolean; function GetVisible: Boolean; procedure SetMouseEvents(Value: Boolean); procedure SetVisible(Value: Boolean); function GetInvalid: Boolean; procedure SetInvalid(Value: Boolean); function GetForceUpdate: Boolean; procedure SetForceUpdate(Value: Boolean); protected procedure AddNotification(ALayer: TCustomLayer); procedure Changing; procedure Click; procedure DblClick; function DoHitTest(X, Y: Integer): Boolean; virtual; procedure DoPaint(Buffer: TBitmap32); function GetOwner: TPersistent; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; procedure Notification(ALayer: TCustomLayer); virtual; procedure Paint(Buffer: TBitmap32); virtual; procedure PaintGDI(Canvas: TCanvas); virtual; procedure RemoveNotification(ALayer: TCustomLayer); procedure SetIndex(Value: Integer); virtual; procedure SetCursor(Value: TCursor); virtual; procedure SetLayerCollection(Value: TLayerCollection); virtual; procedure SetLayerOptions(Value: Cardinal); virtual; property Invalid: Boolean read GetInvalid write SetInvalid; property ForceUpdate: Boolean read GetForceUpdate write SetForceUpdate; public constructor Create(ALayerCollection: TLayerCollection); virtual; destructor Destroy; override; procedure BeforeDestruction; override; procedure BringToFront; procedure Changed; overload; override; procedure Changed(const Rect: TRect); reintroduce; overload; procedure Update; overload; procedure Update(const Rect: TRect); overload; function HitTest(X, Y: Integer): Boolean; procedure SendToBack; procedure SetAsMouseListener; property Cursor: TCursor read FCursor write SetCursor; property Index: Integer read GetIndex write SetIndex; property LayerCollection: TLayerCollection read FLayerCollection write SetLayerCollection; property LayerOptions: Cardinal read FLayerOptions write SetLayerOptions; property LayerStates: TLayerStates read FLayerStates; property MouseEvents: Boolean read GetMouseEvents write SetMouseEvents; property Tag: Integer read FTag write FTag; property Visible: Boolean read GetVisible write SetVisible; property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; property OnHitTest: THitTestEvent read FOnHitTest write FOnHitTest; property OnPaint: TPaintLayerEvent read FOnPaint write FOnPaint; property OnClick: TNotifyEvent read FOnClick write FOnClick; property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick; property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown; property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove; property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp; end; TPositionedLayer = class(TCustomLayer) private FLocation: TFloatRect; FScaled: Boolean; procedure SetLocation(const Value: TFloatRect); procedure SetScaled(Value: Boolean); protected function DoHitTest(X, Y: Integer): Boolean; override; procedure DoSetLocation(const NewLocation: TFloatRect); virtual; public constructor Create(ALayerCollection: TLayerCollection); override; function GetAdjustedRect(const R: TFloatRect): TFloatRect; virtual; function GetAdjustedLocation: TFloatRect; property Location: TFloatRect read FLocation write SetLocation; property Scaled: Boolean read FScaled write SetScaled; end; TBitmapLayer = class(TPositionedLayer) private FBitmap: TBitmap32; FAlphaHit: Boolean; FCropped: Boolean; procedure BitmapAreaChanged(Sender: TObject; const Area: TRect; const Info: Cardinal); procedure SetBitmap(Value: TBitmap32); procedure SetCropped(Value: Boolean); protected function DoHitTest(X, Y: Integer): Boolean; override; procedure Paint(Buffer: TBitmap32); override; public constructor Create(ALayerCollection: TLayerCollection); override; destructor Destroy; override; property AlphaHit: Boolean read FAlphaHit write FAlphaHit; property Bitmap: TBitmap32 read FBitmap write SetBitmap; property Cropped: Boolean read FCropped write SetCropped; end; TRBDragState = (dsNone, dsMove, dsSizeL, dsSizeT, dsSizeR, dsSizeB, dsSizeTL, dsSizeTR, dsSizeBL, dsSizeBR); TRBHandles = set of (rhCenter, rhSides, rhCorners, rhFrame, rhNotLeftSide, rhNotRightSide, rhNotTopSide, rhNotBottomSide, rhNotTLCorner, rhNotTRCorner, rhNotBLCorner, rhNotBRCorner); TRBOptions = set of (roProportional, roConstrained, roQuantized); TRBResizingEvent = procedure( Sender: TObject; const OldLocation: TFloatRect; var NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState) of object; TRBConstrainEvent = TRBResizingEvent; TRubberbandPassMouse = class(TPersistent) private FOwner: TRubberbandLayer; FEnabled: Boolean; FToChild: Boolean; FLayerUnderCursor: Boolean; FCancelIfPassed: Boolean; protected function GetChildUnderCursor(X, Y: Integer): TPositionedLayer; public constructor Create(AOwner: TRubberbandLayer); property Enabled: Boolean read FEnabled write FEnabled default False; property ToChild: Boolean read FToChild write FToChild default False; property ToLayerUnderCursor: Boolean read FLayerUnderCursor write FLayerUnderCursor default False; property CancelIfPassed: Boolean read FCancelIfPassed write FCancelIfPassed default False; end; TRubberbandLayer = class(TPositionedLayer) private FChildLayer: TPositionedLayer; FFrameStipplePattern: TArrayOfColor32; FFrameStippleStep: TFloat; FFrameStippleCounter: TFloat; FHandleFrame: TColor32; FHandleFill: TColor32; FHandles: TRBHandles; FHandleSize: Integer; FMinWidth: TFloat; FMaxHeight: TFloat; FMinHeight: TFloat; FMaxWidth: TFloat; FOnUserChange: TNotifyEvent; FOnResizing: TRBResizingEvent; FOnConstrain: TRBConstrainEvent; FOptions: TRBOptions; FQuantized: Integer; FPassMouse: TRubberbandPassMouse; procedure SetFrameStippleStep(const Value: TFloat); procedure SetFrameStippleCounter(const Value: TFloat); procedure SetChildLayer(Value: TPositionedLayer); procedure SetHandleFill(Value: TColor32); procedure SetHandleFrame(Value: TColor32); procedure SetHandles(Value: TRBHandles); procedure SetHandleSize(Value: Integer); procedure SetOptions(const Value: TRBOptions); procedure SetQuantized(const Value: Integer); protected FIsDragging: Boolean; FDragState: TRBDragState; FOldLocation: TFloatRect; FMouseShift: TFloatPoint; function DoHitTest(X, Y: Integer): Boolean; override; procedure DoResizing(var OldLocation, NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); virtual; procedure DoConstrain(var OldLocation, NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); virtual; procedure DoSetLocation(const NewLocation: TFloatRect); override; function GetDragState(X, Y: Integer): TRBDragState; virtual; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure Notification(ALayer: TCustomLayer); override; procedure Paint(Buffer: TBitmap32); override; procedure SetLayerOptions(Value: Cardinal); override; procedure SetDragState(const Value: TRBDragState); overload; procedure SetDragState(const Value: TRBDragState; const X, Y: Integer); overload; procedure UpdateChildLayer; public constructor Create(ALayerCollection: TLayerCollection); override; destructor Destroy; override; procedure SetFrameStipple(const Value: Array of TColor32); procedure Quantize; property ChildLayer: TPositionedLayer read FChildLayer write SetChildLayer; property Options: TRBOptions read FOptions write SetOptions; property Handles: TRBHandles read FHandles write SetHandles; property HandleSize: Integer read FHandleSize write SetHandleSize; property HandleFill: TColor32 read FHandleFill write SetHandleFill; property HandleFrame: TColor32 read FHandleFrame write SetHandleFrame; property FrameStippleStep: TFloat read FFrameStippleStep write SetFrameStippleStep; property FrameStippleCounter: TFloat read FFrameStippleCounter write SetFrameStippleCounter; property MaxHeight: TFloat read FMaxHeight write FMaxHeight; property MaxWidth: TFloat read FMaxWidth write FMaxWidth; property MinHeight: TFloat read FMinHeight write FMinHeight; property MinWidth: TFloat read FMinWidth write FMinWidth; property Quantized: Integer read FQuantized write SetQuantized default 8; property PassMouseToChild: TRubberbandPassMouse read FPassMouse; property OnUserChange: TNotifyEvent read FOnUserChange write FOnUserChange; property OnConstrain: TRBConstrainEvent read FOnConstrain write FOnConstrain; property OnResizing: TRBResizingEvent read FOnResizing write FOnResizing; end; implementation uses TypInfo, GR32_Image, GR32_LowLevel, GR32_Resamplers, GR32_RepaintOpt, Types; { mouse state mapping } const CStateMap: array [TMouseButton] of TLayerState = (lsMouseLeft, lsMouseRight, lsMouseMiddle {$IFDEF FPC}, lsMouseMiddle, lsMouseMiddle{$ENDIF}); type TImage32Access = class(TCustomImage32); { TLayerCollection } function TLayerCollection.Add(ItemClass: TLayerClass): TCustomLayer; begin Result := ItemClass.Create(Self); Result.Index := FItems.Count - 1; Notify(lnLayerAdded, Result, Result.Index); end; procedure TLayerCollection.Assign(Source: TPersistent); var I: Integer; Item: TCustomLayer; begin if Source is TLayerCollection then begin BeginUpdate; try while FItems.Count > 0 do TCustomLayer(FItems.Last).Free; for I := 0 to TLayerCollection(Source).Count - 1 do begin Item := TLayerCollection(Source).Items[I]; Add(TLayerClass(Item.ClassType)).Assign(Item); end; finally EndUpdate; end; Exit; end; inherited Assign(Source); end; procedure TLayerCollection.BeginUpdate; begin if FUpdateCount = 0 then Changing; Inc(FUpdateCount); end; procedure TLayerCollection.Changed; begin if Assigned(FOnChange) then FOnChange(Self); end; procedure TLayerCollection.Changing; begin if Assigned(FOnChanging) then FOnChanging(Self); end; procedure TLayerCollection.Clear; begin BeginUpdate; try while FItems.Count > 0 do TCustomLayer(FItems.Last).Free; Notify(lnCleared, nil, 0); finally EndUpdate; end; end; constructor TLayerCollection.Create(AOwner: TPersistent); begin FOwner := AOwner; FItems := TList.Create; FMouseEvents := True; end; procedure TLayerCollection.Delete(Index: Integer); begin TCustomLayer(FItems[Index]).Free; end; destructor TLayerCollection.Destroy; begin FUpdateCount := 1; // disable update notification if Assigned(FItems) then Clear; FItems.Free; inherited; end; procedure TLayerCollection.EndUpdate; begin Dec(FUpdateCount); if FUpdateCount = 0 then Changed; Assert(FUpdateCount >= 0, 'Unpaired EndUpdate'); end; function TLayerCollection.FindLayerAtPos(X, Y: Integer; OptionsMask: Cardinal): TCustomLayer; var I: Integer; begin for I := Count - 1 downto 0 do begin Result := Items[I]; if (Result.LayerOptions and OptionsMask) = 0 then Continue; // skip to the next one if Result.HitTest(X, Y) then Exit; end; Result := nil; end; procedure TLayerCollection.GDIUpdate; begin if (FUpdateCount = 0) and Assigned(FOnGDIUpdate) then FOnGDIUpdate(Self); end; function TLayerCollection.GetCount: Integer; begin Result := FItems.Count; end; function TLayerCollection.GetItem(Index: Integer): TCustomLayer; begin Result := FItems[Index]; end; function TLayerCollection.GetOwner: TPersistent; begin Result := FOwner; end; function TLayerCollection.Insert(Index: Integer; ItemClass: TLayerClass): TCustomLayer; begin BeginUpdate; try Result := Add(ItemClass); Result.Index := Index; Notify(lnLayerInserted, Result, Index); finally EndUpdate; end; end; procedure TLayerCollection.InsertItem(Item: TCustomLayer); var Index: Integer; begin BeginUpdate; try Index := FItems.Add(Item); Item.FLayerCollection := Self; Notify(lnLayerAdded, Item, Index); finally EndUpdate; end; end; function TLayerCollection.LocalToViewport(const APoint: TFloatPoint; AScaled: Boolean): TFloatPoint; var ScaleX, ScaleY, ShiftX, ShiftY: TFloat; begin if AScaled then begin GetViewportShift(ShiftX, ShiftY); GetViewportScale(ScaleX, ScaleY); Result.X := APoint.X * ScaleX + ShiftX; Result.Y := APoint.Y * ScaleY + ShiftY; end else Result := APoint; end; function TLayerCollection.ViewportToLocal(const APoint: TFloatPoint; AScaled: Boolean): TFloatPoint; var ScaleX, ScaleY, ShiftX, ShiftY: TFloat; begin if AScaled then begin GetViewportShift(ShiftX, ShiftY); GetViewportScale(ScaleX, ScaleY); Result.X := (APoint.X - ShiftX) / ScaleX; Result.Y := (APoint.Y - ShiftY) / ScaleY; end else Result := APoint; end; function TLayerCollection.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): TCustomLayer; begin if Assigned(MouseListener) then Result := MouseListener else Result := FindLayerAtPos(X, Y, LOB_MOUSE_EVENTS); if (Result <> MouseListener) and ((Result = nil) or ((Result.FLayerOptions and LOB_NO_CAPTURE) = 0)) then MouseListener := Result; // capture the mouse if Assigned(MouseListener) then begin Include(MouseListener.FLayerStates, CStateMap[Button]); MouseListener.MouseDown(Button, Shift, X, Y); end; end; function TLayerCollection.MouseMove(Shift: TShiftState; X, Y: Integer): TCustomLayer; begin Result := MouseListener; if Result = nil then Result := FindLayerAtPos(X, Y, LOB_MOUSE_EVENTS); if Assigned(Result) then Result.MouseMove(Shift, X, Y) else if FOwner is TControl then Screen.Cursor := TControl(FOwner).Cursor; end; function TLayerCollection.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): TCustomLayer; begin Result := MouseListener; if Result = nil then Result := FindLayerAtPos(X, Y, LOB_MOUSE_EVENTS); if Assigned(Result) then begin Exclude(Result.FLayerStates, CStateMap[Button]); Result.MouseUp(Button, Shift, X, Y); end; if Assigned(MouseListener) and (MouseListener.FLayerStates * [lsMouseLeft, lsMouseRight, lsMouseMiddle] = []) then MouseListener := nil; // reset mouse capture end; procedure TLayerCollection.Notify(Action: TLayerListNotification; Layer: TCustomLayer; Index: Integer); begin if Assigned(FOnListNotify) then FOnListNotify(Self, Action, Layer, Index); end; procedure TLayerCollection.RemoveItem(Item: TCustomLayer); var Index: Integer; begin BeginUpdate; try Index := FItems.IndexOf(Item); if Index >= 0 then begin FItems.Delete(Index); Item.FLayerCollection := nil; Notify(lnLayerDeleted, Item, Index); end; finally EndUpdate; end; end; procedure TLayerCollection.SetItem(Index: Integer; Value: TCustomLayer); begin TCollectionItem(FItems[Index]).Assign(Value); end; procedure TLayerCollection.SetMouseEvents(Value: Boolean); begin FMouseEvents := Value; MouseListener := nil; end; procedure TLayerCollection.SetMouseListener(Value: TCustomLayer); begin if Value <> FMouseListener then begin if Assigned(FMouseListener) then FMouseListener.FLayerStates := FMouseListener.FLayerStates - [lsMouseLeft, lsMouseRight, lsMouseMiddle]; FMouseListener := Value; end; end; procedure TLayerCollection.DoUpdateArea(const Rect: TRect); begin if Assigned(FOnAreaUpdated) then FOnAreaUpdated(Self, Rect, AREAINFO_RECT); Changed; end; procedure TLayerCollection.DoUpdateLayer(Layer: TCustomLayer); begin if Assigned(FOnLayerUpdated) then FOnLayerUpdated(Self, Layer); Changed; end; procedure TLayerCollection.GetViewportScale(out ScaleX, ScaleY: TFloat); begin if Assigned(FOnGetViewportScale) then FOnGetViewportScale(Self, ScaleX, ScaleY) else begin ScaleX := 1; ScaleY := 1; end; end; procedure TLayerCollection.GetViewportShift(out ShiftX, ShiftY: TFloat); begin if Assigned(FOnGetViewportShift) then FOnGetViewportShift(Self, ShiftX, ShiftY) else begin ShiftX := 0; ShiftY := 0; end; end; {$IFDEF COMPILER2009_UP} { TLayerEnum } constructor TLayerEnum.Create(ALayerCollection: TLayerCollection); begin inherited Create; FLayerCollection := ALayerCollection; FIndex := -1; end; function TLayerEnum.GetCurrent: TCustomLayer; begin Result := FLayerCollection.Items[FIndex]; end; function TLayerEnum.MoveNext: Boolean; begin Result := FIndex < Pred(FLayerCollection.Count); if Result then Inc(FIndex); end; { TLayerCollectionHelper } function TLayerCollectionHelper.GetEnumerator: TLayerEnum; begin Result := TLayerEnum.Create(Self); end; {$ENDIF} { TCustomLayer } constructor TCustomLayer.Create(ALayerCollection: TLayerCollection); begin LayerCollection := ALayerCollection; FLayerOptions := LOB_VISIBLE; end; destructor TCustomLayer.Destroy; var I: Integer; begin if Assigned(FFreeNotifies) then begin for I := FFreeNotifies.Count - 1 downto 0 do begin TCustomLayer(FFreeNotifies[I]).Notification(Self); if FFreeNotifies = nil then Break; end; FFreeNotifies.Free; FFreeNotifies := nil; end; SetLayerCollection(nil); inherited; end; procedure TCustomLayer.AddNotification(ALayer: TCustomLayer); begin if not Assigned(FFreeNotifies) then FFreeNotifies := TList.Create; if FFreeNotifies.IndexOf(ALayer) < 0 then FFreeNotifies.Add(ALayer); end; procedure TCustomLayer.BeforeDestruction; begin if Assigned(FOnDestroy) then FOnDestroy(Self); inherited; end; procedure TCustomLayer.BringToFront; begin Index := LayerCollection.Count; end; procedure TCustomLayer.Changed; begin if UpdateCount > 0 then Exit; if Assigned(FLayerCollection) and ((FLayerOptions and LOB_NO_UPDATE) = 0) then begin Update; if Visible then FLayerCollection.Changed else if (FLayerOptions and LOB_GDI_OVERLAY) <> 0 then FLayerCollection.GDIUpdate; inherited; end; end; procedure TCustomLayer.Changed(const Rect: TRect); begin if UpdateCount > 0 then Exit; if Assigned(FLayerCollection) and ((FLayerOptions and LOB_NO_UPDATE) = 0) then begin Update(Rect); if Visible then FLayerCollection.Changed else if (FLayerOptions and LOB_GDI_OVERLAY) <> 0 then FLayerCollection.GDIUpdate; inherited Changed; end; end; procedure TCustomLayer.Changing; begin if UpdateCount > 0 then Exit; if Visible and Assigned(FLayerCollection) and ((FLayerOptions and LOB_NO_UPDATE) = 0) then FLayerCollection.Changing; end; procedure TCustomLayer.Click; begin FClicked := False; if Assigned(FOnClick) then FOnClick(Self); end; procedure TCustomLayer.DblClick; begin FClicked := False; if Assigned(FOnDblClick) then FOnDblClick(Self); end; function TCustomLayer.DoHitTest(X, Y: Integer): Boolean; begin Result := Visible; end; procedure TCustomLayer.DoPaint(Buffer: TBitmap32); begin Paint(Buffer); if Assigned(FOnPaint) then FOnPaint(Self, Buffer); end; function TCustomLayer.GetIndex: Integer; begin if Assigned(FLayerCollection) then Result := FLayerCollection.FItems.IndexOf(Self) else Result := -1; end; function TCustomLayer.GetMouseEvents: Boolean; begin Result := FLayerOptions and LOB_MOUSE_EVENTS <> 0; end; function TCustomLayer.GetOwner: TPersistent; begin Result := FLayerCollection; end; function TCustomLayer.GetVisible: Boolean; begin Result := FLayerOptions and LOB_VISIBLE <> 0; end; function TCustomLayer.HitTest(X, Y: Integer): Boolean; begin Result := DoHitTest(X, Y); if Assigned(FOnHitTest) then FOnHitTest(Self, X, Y, Result); end; procedure TCustomLayer.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Button = mbLeft) then begin if (ssDouble in Shift) then DblClick else FClicked := True; end; if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y); end; procedure TCustomLayer.MouseMove(Shift: TShiftState; X, Y: Integer); begin Screen.Cursor := Cursor; if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y); end; procedure TCustomLayer.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin Screen.Cursor := crDefault; if (Button = mbLeft) and FClicked then Click; if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y); end; procedure TCustomLayer.Notification(ALayer: TCustomLayer); begin // do nothing by default end; procedure TCustomLayer.Paint(Buffer: TBitmap32); begin // descendants override this method end; procedure TCustomLayer.PaintGDI(Canvas: TCanvas); begin // descendants override this method end; procedure TCustomLayer.RemoveNotification(ALayer: TCustomLayer); begin if Assigned(FFreeNotifies) then begin FFreeNotifies.Remove(ALayer); if FFreeNotifies.Count = 0 then begin FFreeNotifies.Free; FFreeNotifies := nil; end; end; end; procedure TCustomLayer.SendToBack; begin Index := 0; end; procedure TCustomLayer.SetAsMouseListener; begin FLayerCollection.MouseListener := Self; Screen.Cursor := Cursor; end; procedure TCustomLayer.SetCursor(Value: TCursor); begin if Value <> FCursor then begin FCursor := Value; if FLayerCollection.MouseListener = Self then Screen.Cursor := Value; end; end; procedure TCustomLayer.SetIndex(Value: Integer); var CurIndex: Integer; begin CurIndex := GetIndex; if (CurIndex >= 0) and (CurIndex <> Value) then with FLayerCollection do begin if Value < 0 then Value := 0; if Value >= Count then Value := Count - 1; if Value <> CurIndex then begin if Visible then BeginUpdate; try FLayerCollection.FItems.Move(CurIndex, Value); finally if Visible then EndUpdate; end; end; end; end; procedure TCustomLayer.SetLayerCollection(Value: TLayerCollection); begin if FLayerCollection <> Value then begin if Assigned(FLayerCollection) then begin if FLayerCollection.MouseListener = Self then FLayerCollection.MouseListener := nil; FLayerCollection.RemoveItem(Self); end; if Assigned(Value) then Value.InsertItem(Self); FLayerCollection := Value; end; end; procedure TCustomLayer.SetLayerOptions(Value: Cardinal); begin Changing; FLayerOptions := Value; Changed; end; procedure TCustomLayer.SetMouseEvents(Value: Boolean); begin if Value then LayerOptions := LayerOptions or LOB_MOUSE_EVENTS else LayerOptions := LayerOptions and not LOB_MOUSE_EVENTS; end; procedure TCustomLayer.SetVisible(Value: Boolean); begin if Value then LayerOptions := LayerOptions or LOB_VISIBLE else begin ForceUpdate := True; LayerOptions := LayerOptions and not LOB_VISIBLE; ForceUpdate := False; end; end; procedure TCustomLayer.Update; begin if Assigned(FLayerCollection) and (Visible or (LayerOptions and LOB_FORCE_UPDATE <> 0)) then FLayerCollection.DoUpdateLayer(Self); end; procedure TCustomLayer.Update(const Rect: TRect); begin if Assigned(FLayerCollection) then FLayerCollection.DoUpdateArea(Rect); end; function TCustomLayer.GetInvalid: Boolean; begin Result := LayerOptions and LOB_INVALID <> 0; end; procedure TCustomLayer.SetInvalid(Value: Boolean); begin // don't use LayerOptions here since this is internal and we don't want to // trigger Changing and Changed as this will definitely cause a stack overflow. if Value then FLayerOptions := FLayerOptions or LOB_INVALID else FLayerOptions := FLayerOptions and not LOB_INVALID; end; function TCustomLayer.GetForceUpdate: Boolean; begin Result := LayerOptions and LOB_FORCE_UPDATE <> 0; end; procedure TCustomLayer.SetForceUpdate(Value: Boolean); begin // don't use LayerOptions here since this is internal and we don't want to // trigger Changing and Changed as this will definitely cause a stack overflow. if Value then FLayerOptions := FLayerOptions or LOB_FORCE_UPDATE else FLayerOptions := FLayerOptions and not LOB_FORCE_UPDATE; end; { TPositionedLayer } constructor TPositionedLayer.Create(ALayerCollection: TLayerCollection); begin inherited; with FLocation do begin Left := 0; Top := 0; Right := 64; Bottom := 64; end; FLayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS; end; function TPositionedLayer.DoHitTest(X, Y: Integer): Boolean; begin with GetAdjustedRect(FLocation) do Result := (X >= Left) and (X < Right) and (Y >= Top) and (Y < Bottom) and inherited DoHitTest(X, Y); end; procedure TPositionedLayer.DoSetLocation(const NewLocation: TFloatRect); begin FLocation := NewLocation; end; function TPositionedLayer.GetAdjustedLocation: TFloatRect; begin Result := GetAdjustedRect(FLocation); end; function TPositionedLayer.GetAdjustedRect(const R: TFloatRect): TFloatRect; var ScaleX, ScaleY, ShiftX, ShiftY: TFloat; begin if Scaled and Assigned(FLayerCollection) then begin FLayerCollection.GetViewportShift(ShiftX, ShiftY); FLayerCollection.GetViewportScale(ScaleX, ScaleY); with Result do begin Left := R.Left * ScaleX + ShiftX; Top := R.Top * ScaleY + ShiftY; Right := R.Right * ScaleX + ShiftX; Bottom := R.Bottom * ScaleY + ShiftY; end; end else Result := R; end; procedure TPositionedLayer.SetLocation(const Value: TFloatRect); begin Changing; DoSetLocation(Value); Changed; end; procedure TPositionedLayer.SetScaled(Value: Boolean); begin if Value <> FScaled then begin Changing; FScaled := Value; Changed; end; end; { TBitmapLayer } procedure TBitmapLayer.BitmapAreaChanged(Sender: TObject; const Area: TRect; const Info: Cardinal); var T: TRect; ScaleX, ScaleY: TFloat; Width: Integer; begin if Bitmap.Empty then Exit; if Assigned(FLayerCollection) and ((FLayerOptions and LOB_NO_UPDATE) = 0) then begin with GetAdjustedLocation do begin { TODO : Optimize me! } ScaleX := (Right - Left) / FBitmap.Width; ScaleY := (Bottom - Top) / FBitmap.Height; T.Left := Floor(Left + Area.Left * ScaleX); T.Top := Floor(Top + Area.Top * ScaleY); T.Right := Ceil(Left + Area.Right * ScaleX); T.Bottom := Ceil(Top + Area.Bottom * ScaleY); end; Width := Trunc(FBitmap.Resampler.Width) + 1; InflateArea(T, Width, Width); Changed(T); end; end; constructor TBitmapLayer.Create(ALayerCollection: TLayerCollection); begin inherited; FBitmap := TBitmap32.Create; FBitmap.OnAreaChanged := BitmapAreaChanged; end; function TBitmapLayer.DoHitTest(X, Y: Integer): Boolean; var BitmapX, BitmapY: Integer; LayerWidth, LayerHeight: Integer; begin Result := inherited DoHitTest(X, Y); if Result and AlphaHit then begin with GetAdjustedRect(FLocation) do begin LayerWidth := Round(Right - Left); LayerHeight := Round(Bottom - Top); if (LayerWidth < 0.5) or (LayerHeight < 0.5) then Result := False else begin // check the pixel alpha at (X, Y) position BitmapX := Round((X - Left) * Bitmap.Width / LayerWidth); BitmapY := Round((Y - Top) * Bitmap.Height / LayerHeight); if Bitmap.PixelS[BitmapX, BitmapY] and $FF000000 = 0 then Result := False; end; end; end; end; destructor TBitmapLayer.Destroy; begin FBitmap.Free; inherited; end; procedure TBitmapLayer.Paint(Buffer: TBitmap32); var SrcRect, DstRect, ClipRect, TempRect: TRect; ImageRect: TRect; LayerWidth, LayerHeight: TFloat; begin if Bitmap.Empty then Exit; DstRect := MakeRect(GetAdjustedRect(FLocation)); ClipRect := Buffer.ClipRect; GR32.IntersectRect(TempRect, ClipRect, DstRect); if GR32.IsRectEmpty(TempRect) then Exit; SrcRect := MakeRect(0, 0, Bitmap.Width, Bitmap.Height); if Cropped and (LayerCollection.FOwner is TCustomImage32) and not (TImage32Access(LayerCollection.FOwner).PaintToMode) then begin with DstRect do begin LayerWidth := Right - Left; LayerHeight := Bottom - Top; end; if (LayerWidth < 0.5) or (LayerHeight < 0.5) then Exit; ImageRect := TCustomImage32(LayerCollection.FOwner).GetBitmapRect; GR32.IntersectRect(ClipRect, ClipRect, ImageRect); end; StretchTransfer(Buffer, DstRect, ClipRect, FBitmap, SrcRect, FBitmap.Resampler, FBitmap.DrawMode, FBitmap.OnPixelCombine); end; procedure TBitmapLayer.SetBitmap(Value: TBitmap32); begin FBitmap.Assign(Value); end; procedure TBitmapLayer.SetCropped(Value: Boolean); begin if Value <> FCropped then begin FCropped := Value; Changed; end; end; { TRubberbandPassMouse } constructor TRubberbandPassMouse.Create(AOwner: TRubberbandLayer); begin FOwner := AOwner; FEnabled := False; FToChild := False; FLayerUnderCursor := False; FCancelIfPassed := False; end; function TRubberbandPassMouse.GetChildUnderCursor(X, Y: Integer): TPositionedLayer; var Layer: TCustomLayer; Index: Integer; begin Result := nil; for Index := FOwner.LayerCollection.Count - 1 downto 0 do begin Layer := FOwner.LayerCollection.Items[Index]; if ((Layer.LayerOptions and LOB_MOUSE_EVENTS) > 0) and (Layer is TPositionedLayer) and Layer.HitTest(X, Y) then begin Result := TPositionedLayer(Layer); Exit; end; end; end; { TRubberbandLayer } constructor TRubberbandLayer.Create(ALayerCollection: TLayerCollection); begin inherited; FHandleFrame := clBlack32; FHandleFill := clWhite32; FHandles := [rhCenter, rhSides, rhCorners, rhFrame]; FHandleSize := 3; FMinWidth := 10; FMinHeight := 10; FQuantized := 8; FLayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS; SetFrameStipple([clWhite32, clWhite32, clBlack32, clBlack32]); FPassMouse := TRubberbandPassMouse.Create(Self); FFrameStippleStep := 1; FFrameStippleCounter := 0; end; destructor TRubberbandLayer.Destroy; begin FPassMouse.Free; inherited; end; function TRubberbandLayer.DoHitTest(X, Y: Integer): Boolean; begin Result := GetDragState(X, Y) <> dsNone; end; procedure TRubberbandLayer.DoResizing(var OldLocation, NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); begin if Assigned(FOnResizing) then FOnResizing(Self, OldLocation, NewLocation, DragState, Shift); end; procedure TRubberbandLayer.DoConstrain(var OldLocation, NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); begin if Assigned(FOnConstrain) then FOnConstrain(Self, OldLocation, NewLocation, DragState, Shift); end; procedure TRubberbandLayer.DoSetLocation(const NewLocation: TFloatRect); begin inherited; UpdateChildLayer; end; function TRubberbandLayer.GetDragState(X, Y: Integer): TRBDragState; var R: TRect; dh_center, dh_sides, dh_corners: Boolean; dl, dt, dr, db, dx, dy: Boolean; Sz: Integer; begin Result := dsNone; Sz := FHandleSize + 1; dh_center := rhCenter in FHandles; dh_sides := rhSides in FHandles; dh_corners := rhCorners in FHandles; R := MakeRect(GetAdjustedRect(FLocation)); with R do begin Dec(Right); Dec(Bottom); dl := Abs(Left - X) <= Sz; dr := Abs(Right - X) <= Sz; dx := Abs((Left + Right) div 2 - X) <= Sz; dt := Abs(Top - Y) <= Sz; db := Abs(Bottom - Y) <= Sz; dy := Abs((Top + Bottom) div 2 - Y) <= Sz; end; if dr and db and dh_corners and not(rhNotBRCorner in FHandles) then Result := dsSizeBR else if dl and db and dh_corners and not(rhNotBLCorner in FHandles) then Result := dsSizeBL else if dr and dt and dh_corners and not(rhNotTRCorner in FHandles) then Result := dsSizeTR else if dl and dt and dh_corners and not(rhNotTLCorner in FHandles) then Result := dsSizeTL else if dr and dy and dh_sides and not(rhNotRightSide in FHandles) then Result := dsSizeR else if db and dx and dh_sides and not(rhNotBottomSide in FHandles) then Result := dsSizeB else if dl and dy and dh_sides and not(rhNotLeftSide in FHandles) then Result := dsSizeL else if dt and dx and dh_sides and not(rhNotTopSide in FHandles) then Result := dsSizeT else if dh_center and GR32.PtInRect(R, GR32.Point(X, Y)) then Result := dsMove; end; procedure TRubberbandLayer.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var PositionedLayer: TPositionedLayer; begin if FPassMouse.Enabled then begin if FPassMouse.ToLayerUnderCursor then PositionedLayer := FPassMouse.GetChildUnderCursor(X, Y) else PositionedLayer := ChildLayer; if FPassMouse.ToChild and Assigned(ChildLayer) then begin ChildLayer.MouseDown(Button, Shift, X, Y); if FPassMouse.CancelIfPassed then Exit; end; if (PositionedLayer <> ChildLayer) and Assigned(PositionedLayer) then begin PositionedLayer.MouseDown(Button, Shift, X, Y); if FPassMouse.CancelIfPassed then Exit; end; end; if FIsDragging then Exit; SetDragState(GetDragState(X, Y), X, Y); inherited; end; procedure TRubberbandLayer.MouseMove(Shift: TShiftState; X, Y: Integer); const CURSOR_ID: array [TRBDragState] of TCursor = (crDefault, crDefault, crSizeWE, crSizeNS, crSizeWE, crSizeNS, crSizeNWSE, crSizeNESW, crSizeNESW, crSizeNWSE); var Mx, My: TFloat; L, T, R, B, W, H: TFloat; Quantize: Boolean; ALoc, NewLocation: TFloatRect; procedure IncLT(var LT, RB: TFloat; Delta, MinSize, MaxSize: TFloat); begin LT := LT + Delta; if RB - LT < MinSize then LT := RB - MinSize; if MaxSize >= MinSize then if RB - LT > MaxSize then LT := RB - MaxSize; end; procedure IncRB(var LT, RB: TFloat; Delta, MinSize, MaxSize: TFloat); begin RB := RB + Delta; if RB - LT < MinSize then RB := LT + MinSize; if MaxSize >= MinSize then if RB - LT > MaxSize then RB := LT + MaxSize; end; begin if not FIsDragging then begin FDragState := GetDragState(X, Y); if FDragState = dsMove then Screen.Cursor := Cursor else Screen.Cursor := CURSOR_ID[FDragState]; end else begin Mx := X - FMouseShift.X; My := Y - FMouseShift.Y; if Scaled then with Location do begin ALoc := GetAdjustedRect(FLocation); if GR32.IsRectEmpty(ALoc) then Exit; Mx := (Mx - ALoc.Left) / (ALoc.Right - ALoc.Left) * (Right - Left) + Left; My := (My - ALoc.Top) / (ALoc.Bottom - ALoc.Top) * (Bottom - Top) + Top; end; with FOldLocation do begin L := Left; T := Top; R := Right; B := Bottom; W := R - L; H := B - T; end; Quantize := (roQuantized in Options) and not (ssAlt in Shift); if FDragState = dsMove then begin L := Mx; T := My; if Quantize then begin L := Round(L / FQuantized) * FQuantized; T := Round(T / FQuantized) * FQuantized; end; R := L + W; B := T + H; end else begin if FDragState in [dsSizeL, dsSizeTL, dsSizeBL] then begin IncLT(L, R, Mx - L, MinWidth, MaxWidth); if Quantize then L := Round(L / FQuantized) * FQuantized; end; if FDragState in [dsSizeR, dsSizeTR, dsSizeBR] then begin IncRB(L, R, Mx - R, MinWidth, MaxWidth); if Quantize then R := Round(R / FQuantized) * FQuantized; end; if FDragState in [dsSizeT, dsSizeTL, dsSizeTR] then begin IncLT(T, B, My - T, MinHeight, MaxHeight); if Quantize then T := Round(T / FQuantized) * FQuantized; end; if FDragState in [dsSizeB, dsSizeBL, dsSizeBR] then begin IncRB(T, B, My - B, MinHeight, MaxHeight); if Quantize then B := Round(B / FQuantized) * FQuantized; end; end; NewLocation := FloatRect(L, T, R, B); if roConstrained in FOptions then DoConstrain(FOldLocation, NewLocation, FDragState, Shift); if roProportional in FOptions then begin case FDragState of dsSizeB, dsSizeBR: NewLocation.Right := FOldLocation.Left + (FOldLocation.Right - FOldLocation.Left) * (NewLocation.Bottom - NewLocation.Top) / (FOldLocation.Bottom - FOldLocation.Top); dsSizeT, dsSizeTL: NewLocation.Left := FOldLocation.Right - (FOldLocation.Right - FOldLocation.Left) * (NewLocation.Bottom - NewLocation.Top) / (FOldLocation.Bottom - FOldLocation.Top); dsSizeR, dsSizeBL: NewLocation.Bottom := FOldLocation.Top + (FOldLocation.Bottom - FOldLocation.Top) * (NewLocation.Right - NewLocation.Left) / (FOldLocation.Right - FOldLocation.Left); dsSizeL, dsSizeTR: NewLocation.Top := FOldLocation.Bottom - (FOldLocation.Bottom - FOldLocation.Top) * (NewLocation.Right - NewLocation.Left) / (FOldLocation.Right - FOldLocation.Left); end; end; DoResizing(FOldLocation, NewLocation, FDragState, Shift); if (NewLocation.Left <> Location.Left) or (NewLocation.Right <> Location.Right) or (NewLocation.Top <> Location.Top) or (NewLocation.Bottom <> Location.Bottom) then begin Location := NewLocation; if Assigned(FOnUserChange) then FOnUserChange(Self); end; end; end; procedure TRubberbandLayer.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var PositionedLayer: TPositionedLayer; begin if FPassMouse.Enabled then begin if FPassMouse.ToLayerUnderCursor then PositionedLayer := FPassMouse.GetChildUnderCursor(X, Y) else PositionedLayer := ChildLayer; if FPassMouse.ToChild and Assigned(ChildLayer) then begin ChildLayer.MouseUp(Button, Shift, X, Y); if FPassMouse.CancelIfPassed then Exit; end; if (PositionedLayer <> ChildLayer) and Assigned(PositionedLayer) then begin PositionedLayer.MouseUp(Button, Shift, X, Y); if FPassMouse.CancelIfPassed then Exit; end; end; FIsDragging := False; inherited; end; procedure TRubberbandLayer.Notification(ALayer: TCustomLayer); begin if ALayer = FChildLayer then FChildLayer := nil; end; procedure TRubberbandLayer.Paint(Buffer: TBitmap32); var Cx, Cy: Integer; R: TRect; procedure DrawHandle(X, Y: Integer); begin Buffer.FillRectTS(X - FHandleSize, Y - FHandleSize, X + FHandleSize, Y + FHandleSize, FHandleFill); Buffer.FrameRectTS(X - FHandleSize, Y - FHandleSize, X + FHandleSize, Y + FHandleSize, FHandleFrame); end; begin R := MakeRect(GetAdjustedRect(FLocation)); with R do begin if rhFrame in FHandles then begin Buffer.SetStipple(FFrameStipplePattern); Buffer.StippleCounter := 0; Buffer.StippleStep := FFrameStippleStep; Buffer.StippleCounter := FFrameStippleCounter; Buffer.FrameRectTSP(Left, Top, Right, Bottom); end; if rhCorners in FHandles then begin if not(rhNotTLCorner in FHandles) then DrawHandle(Left, Top); if not(rhNotTRCorner in FHandles) then DrawHandle(Right, Top); if not(rhNotBLCorner in FHandles) then DrawHandle(Left, Bottom); if not(rhNotBRCorner in FHandles) then DrawHandle(Right, Bottom); end; if rhSides in FHandles then begin Cx := (Left + Right) div 2; Cy := (Top + Bottom) div 2; if not(rhNotTopSide in FHandles) then DrawHandle(Cx, Top); if not(rhNotLeftSide in FHandles) then DrawHandle(Left, Cy); if not(rhNotRightSide in FHandles) then DrawHandle(Right, Cy); if not(rhNotBottomSide in FHandles) then DrawHandle(Cx, Bottom); end; end; end; procedure TRubberbandLayer.Quantize; begin Location := FloatRect( Round(Location.Left / Quantized) * Quantized, Round(Location.Top / Quantized) * Quantized, Round(Location.Right / Quantized) * Quantized, Round(Location.Bottom / Quantized) * Quantized); end; procedure TRubberbandLayer.SetChildLayer(Value: TPositionedLayer); begin if Assigned(FChildLayer) then RemoveNotification(FChildLayer); FChildLayer := Value; if Assigned(Value) then begin Location := Value.Location; Scaled := Value.Scaled; AddNotification(FChildLayer); end; end; procedure TRubberbandLayer.SetDragState(const Value: TRBDragState); begin SetDragState(Value, 0, 0); end; procedure TRubberbandLayer.SetDragState(const Value: TRBDragState; const X, Y: Integer); var ALoc: TFloatRect; begin FDragState := Value; FIsDragging := FDragState <> dsNone; if FIsDragging then begin FOldLocation := Location; ALoc := GetAdjustedRect(FLocation); case FDragState of dsMove: FMouseShift := FloatPoint(X - ALoc.Left, Y - ALoc.Top); else FMouseShift := FloatPoint(0, 0); end; end; end; procedure TRubberbandLayer.SetHandleFill(Value: TColor32); begin if Value <> FHandleFill then begin FHandleFill := Value; FLayerCollection.GDIUpdate; end; end; procedure TRubberbandLayer.SetHandleFrame(Value: TColor32); begin if Value <> FHandleFrame then begin FHandleFrame := Value; FLayerCollection.GDIUpdate; end; end; procedure TRubberbandLayer.SetHandles(Value: TRBHandles); begin if Value <> FHandles then begin FHandles := Value; FLayerCollection.GDIUpdate; end; end; procedure TRubberbandLayer.SetHandleSize(Value: Integer); begin if Value < 1 then Value := 1; if Value <> FHandleSize then begin FHandleSize := Value; FLayerCollection.GDIUpdate; end; end; procedure TRubberbandLayer.SetFrameStipple(const Value: Array of TColor32); var L: Integer; begin L := High(Value) + 1; SetLength(FFrameStipplePattern, L); MoveLongword(Value[0], FFrameStipplePattern[0], L); end; procedure TRubberbandLayer.SetFrameStippleStep(const Value: TFloat); begin if Value <> FFrameStippleStep then begin FFrameStippleStep := Value; FLayerCollection.GDIUpdate; end; end; procedure TRubberbandLayer.UpdateChildLayer; begin if Assigned(FChildLayer) then FChildLayer.Location := Location; end; procedure TRubberbandLayer.SetFrameStippleCounter(const Value: TFloat); begin if Value <> FFrameStippleCounter then begin FFrameStippleCounter := Value; FLayerCollection.GDIUpdate; end; end; procedure TRubberbandLayer.SetLayerOptions(Value: Cardinal); begin Changing; FLayerOptions := Value and not LOB_NO_UPDATE; // workaround for changed behaviour Changed; end; procedure TRubberbandLayer.SetOptions(const Value: TRBOptions); begin FOptions := Value; end; procedure TRubberbandLayer.SetQuantized(const Value: Integer); begin if Value < 1 then raise Exception.Create('Value must be larger than zero!'); FQuantized := Value; end; end. |
Added src/graphics32/GR32_LowLevel.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 | unit GR32_LowLevel; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Michael Hansen <dyster_tid@hotmail.com> * Andre Beckedorf <Andre@metaException.de> * Mattias Andersson <mattias@centaurix.com> * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} {$IFDEF PUREPASCAL} {$DEFINE USENATIVECODE} {$DEFINE USEMOVE} {$ENDIF} {$IFDEF USEINLINING} {$DEFINE USENATIVECODE} {$ENDIF} uses Graphics, GR32, GR32_Math; { Clamp function restricts value to [0..255] range } function Clamp(const Value: Integer): Integer; overload; {$IFDEF USEINLINING} inline; {$ENDIF} { An analogue of FillChar for 32 bit values } var FillLongword: procedure(var X; Count: Cardinal; Value: Longword); procedure FillWord(var X; Count: Cardinal; Value: Longword); { An analogue of Move for 32 bit values } {$IFDEF USEMOVE} procedure MoveLongword(const Source; var Dest; Count: Integer); {$IFDEF USEINLINING} inline; {$ENDIF} {$ELSE} procedure MoveLongword(const Source; var Dest; Count: Integer); {$ENDIF} procedure MoveWord(const Source; var Dest; Count: Integer); {$IFDEF USESTACKALLOC} { Allocates a 'small' block of memory on the stack } function StackAlloc(Size: Integer): Pointer; register; { Pops memory allocated by StackAlloc } procedure StackFree(P: Pointer); register; {$ENDIF} { Exchange two 32-bit values } procedure Swap(var A, B: Pointer); overload;{$IFDEF USEINLINING} inline; {$ENDIF} procedure Swap(var A, B: Integer); overload;{$IFDEF USEINLINING} inline; {$ENDIF} procedure Swap(var A, B: TFixed); overload;{$IFDEF USEINLINING} inline; {$ENDIF} procedure Swap(var A, B: TColor32); overload;{$IFDEF USEINLINING} inline; {$ENDIF} procedure Swap32(var A, B); overload;{$IFDEF USEINLINING} inline; {$ENDIF} { Exchange A <-> B only if B < A } procedure TestSwap(var A, B: Integer); overload;{$IFDEF USEINLINING} inline; {$ENDIF} procedure TestSwap(var A, B: TFixed); overload;{$IFDEF USEINLINING} inline; {$ENDIF} { Exchange A <-> B only if B < A then restrict both to [0..Size-1] range } { returns true if resulting range has common points with [0..Size-1] range } function TestClip(var A, B: Integer; const Size: Integer): Boolean; overload; function TestClip(var A, B: Integer; const Start, Stop: Integer): Boolean; overload; { Returns value constrained to [Lo..Hi] range} function Constrain(const Value, Lo, Hi: Integer): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} overload; function Constrain(const Value, Lo, Hi: Single): Single; {$IFDEF USEINLINING} inline; {$ENDIF} overload; { Returns value constrained to [min(Constrain1, Constrain2)..max(Constrain1, Constrain2] range} function SwapConstrain(const Value: Integer; Constrain1, Constrain2: Integer): Integer; { Returns min./max. value of A, B and C } function Min(const A, B, C: Integer): Integer; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Max(const A, B, C: Integer): Integer; overload; {$IFDEF USEINLINING} inline; {$ENDIF} { Clamp integer value to [0..Max] range } function Clamp(Value, Max: Integer): Integer; overload; {$IFDEF USEINLINING} inline; {$ENDIF} { Same but [Min..Max] range } function Clamp(Value, Min, Max: Integer): Integer; overload; {$IFDEF USEINLINING} inline; {$ENDIF} { Wrap integer value to [0..Max] range } function Wrap(Value, Max: Integer): Integer; overload; { Same but [Min..Max] range } function Wrap(Value, Min, Max: Integer): Integer; overload; { Wrap single value to [0..Max] range } function Wrap(Value, Max: Single): Single; overload; {$IFDEF USEINLINING} inline; {$ENDIF} overload; { Fast Wrap alternatives for cases where range + 1 is a power of two } function WrapPow2(Value, Max: Integer): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} overload; function WrapPow2(Value, Min, Max: Integer): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} overload; { Mirror integer value in [0..Max] range } function Mirror(Value, Max: Integer): Integer; overload; { Same but [Min..Max] range } function Mirror(Value, Min, Max: Integer): Integer; overload; { Fast Mirror alternatives for cases where range + 1 is a power of two } function MirrorPow2(Value, Max: Integer): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} overload; function MirrorPow2(Value, Min, Max: Integer): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} overload; { Functions to determine appropiate wrap procs (normal or power of 2 optimized)} function GetOptimalWrap(Max: Integer): TWrapProc; {$IFDEF USEINLINING} inline; {$ENDIF} overload; function GetOptimalWrap(Min, Max: Integer): TWrapProcEx; {$IFDEF USEINLINING} inline; {$ENDIF} overload; function GetOptimalMirror(Max: Integer): TWrapProc; {$IFDEF USEINLINING} inline; {$ENDIF} overload; function GetOptimalMirror(Min, Max: Integer): TWrapProcEx; {$IFDEF USEINLINING} inline; {$ENDIF} overload; { Functions to retrieve correct WrapProc given WrapMode (and range) } function GetWrapProc(WrapMode: TWrapMode): TWrapProc; overload; function GetWrapProc(WrapMode: TWrapMode; Max: Integer): TWrapProc; overload; function GetWrapProcEx(WrapMode: TWrapMode): TWrapProcEx; overload; function GetWrapProcEx(WrapMode: TWrapMode; Min, Max: Integer): TWrapProcEx; overload; const WRAP_PROCS: array[TWrapMode] of TWrapProc = (Clamp, Wrap, Mirror); WRAP_PROCS_EX: array[TWrapMode] of TWrapProcEx = (Clamp, Wrap, Mirror); { Fast Value div 255, correct result with Value in [0..66298] range } function Div255(Value: Cardinal): Cardinal; {$IFDEF USEINLINING} inline; {$ENDIF} { shift right with sign conservation } function SAR_3(Value: Integer): Integer; function SAR_4(Value: Integer): Integer; function SAR_6(Value: Integer): Integer; function SAR_8(Value: Integer): Integer; function SAR_9(Value: Integer): Integer; function SAR_11(Value: Integer): Integer; function SAR_12(Value: Integer): Integer; function SAR_13(Value: Integer): Integer; function SAR_14(Value: Integer): Integer; function SAR_15(Value: Integer): Integer; function SAR_16(Value: Integer): Integer; { ColorSwap exchanges ARGB <-> ABGR and fills A with $FF } function ColorSwap(WinColor: TColor): TColor32; implementation uses {$IFDEF FPC} SysUtils, {$ENDIF} GR32_System, GR32_Bindings; {$R-}{$Q-} // switch off overflow and range checking function Clamp(const Value: Integer): Integer; {$IFDEF USENATIVECODE} begin if Value > 255 then Result := 255 else if Value < 0 then Result := 0 else Result := Value; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} // in x64 calling convention parameters are passed in ECX, EDX, R8 & R9 MOV EAX,ECX {$ENDIF} TEST EAX,$FFFFFF00 JNZ @1 RET @1: JS @2 MOV EAX,$FF RET @2: XOR EAX,EAX {$ENDIF} end; procedure FillLongword_Pas(var X; Count: Cardinal; Value: Longword); var I: Integer; P: PIntegerArray; begin P := PIntegerArray(@X); for I := Count - 1 downto 0 do P[I] := Integer(Value); end; {$IFNDEF PUREPASCAL} procedure FillLongword_ASM(var X; Count: Cardinal; Value: Longword); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX = X; EDX = Count; ECX = Value PUSH EDI MOV EDI,EAX // Point EDI to destination MOV EAX,ECX MOV ECX,EDX REP STOSD // Fill count dwords @Exit: POP EDI {$ENDIF} {$IFDEF TARGET_x64} // ECX = X; EDX = Count; R8 = Value PUSH RDI MOV RDI,RCX // Point EDI to destination MOV RAX,R8 // copy value from R8 to RAX (EAX) MOV ECX,EDX // copy count to ECX TEST ECX,ECX JS @Exit REP STOSD // Fill count dwords @Exit: POP RDI {$ENDIF} end; procedure FillLongword_MMX(var X; Count: Cardinal; Value: Longword); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX = X; EDX = Count; ECX = Value TEST EDX, EDX // if Count = 0 then JZ @Exit // Exit PUSH EDI MOV EDI, EAX MOV EAX, EDX SHR EAX, 1 SHL EAX, 1 SUB EAX, EDX JE @QLoopIni MOV [EDI], ECX ADD EDI, 4 DEC EDX JZ @ExitPOP @QLoopIni: MOVD MM1, ECX PUNPCKLDQ MM1, MM1 SHR EDX, 1 @QLoop: MOVQ [EDI], MM1 ADD EDI, 8 DEC EDX JNZ @QLoop EMMS @ExitPOP: POP EDI @Exit: {$ENDIF} {$IFDEF TARGET_x64} // RCX = X; RDX = Count; R8 = Value TEST RDX, RDX // if Count = 0 then JZ @Exit // Exit MOV RAX, RCX // RAX = X PUSH RDI // store RDI on stack MOV R9, RDX // R9 = Count MOV RDI, RDX // RDI = Count SHR RDI, 1 // RDI = RDI SHR 1 SHL RDI, 1 // RDI = RDI SHL 1 SUB R9, RDI // check if extra fill is necessary JE @QLoopIni MOV [RAX], R8D // eventually perform extra fill ADD RAX, 4 // Inc(X, 4) DEC RDX // Dec(Count) JZ @ExitPOP // if (Count = 0) then Exit @QLoopIni: MOVD MM0, R8D // MM0 = R8D PUNPCKLDQ MM0, MM0 // unpack MM0 register SHR RDX, 1 // RDX = RDX div 2 @QLoop: MOVQ QWORD PTR [RAX], MM0 // perform fill ADD RAX, 8 // Inc(X, 8) DEC RDX // Dec(X); JNZ @QLoop EMMS @ExitPOP: POP RDI @Exit: {$ENDIF} end; procedure FillLongword_SSE2(var X; Count: Integer; Value: Longword); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX = X; EDX = Count; ECX = Value TEST EDX, EDX // if Count = 0 then JZ @Exit // Exit PUSH EDI // push EDI on stack MOV EDI, EAX // Point EDI to destination CMP EDX, 32 JL @SmallLoop AND EAX, 3 // get aligned count TEST EAX, EAX // check if X is not dividable by 4 JNZ @SmallLoop // otherwise perform slow small loop MOV EAX, EDI SHR EAX, 2 // bytes to count AND EAX, 3 // get aligned count ADD EAX,-4 NEG EAX // get count to advance JZ @SetupMain SUB EDX, EAX // subtract aligning start from total count @AligningLoop: MOV [EDI], ECX ADD EDI, 4 DEC EAX JNZ @AligningLoop @SetupMain: MOV EAX, EDX // EAX = remaining count SHR EAX, 2 SHL EAX, 2 SUB EDX, EAX // EDX = remaining count SHR EAX, 2 MOVD XMM0, ECX PUNPCKLDQ XMM0, XMM0 PUNPCKLDQ XMM0, XMM0 @SSE2Loop: MOVDQA [EDI], XMM0 ADD EDI, 16 DEC EAX JNZ @SSE2Loop @SmallLoop: MOV EAX,ECX MOV ECX,EDX REP STOSD // Fill count dwords @ExitPOP: POP EDI @Exit: {$ENDIF} {$IFDEF TARGET_x64} // RCX = X; RDX = Count; R8 = Value TEST RDX, RDX // if Count = 0 then JZ @Exit // Exit MOV R9, RCX // Point R9 to destination CMP RDX, 32 JL @SmallLoop AND RCX, 3 // get aligned count TEST RCX, RCX // check if X is not dividable by 4 JNZ @SmallLoop // otherwise perform slow small loop MOV RCX, R9 SHR RCX, 2 // bytes to count AND RCX, 3 // get aligned count ADD RCX,-4 NEG RCX // get count to advance JZ @SetupMain SUB RDX, RCX // subtract aligning start from total count @AligningLoop: MOV [R9], R8D ADD R9, 4 DEC RCX JNZ @AligningLoop @SetupMain: MOV RCX, RDX // RCX = remaining count SHR RCX, 2 SHL RCX, 2 SUB RDX, RCX // RDX = remaining count SHR RCX, 2 MOVD XMM0, R8D PUNPCKLDQ XMM0, XMM0 PUNPCKLDQ XMM0, XMM0 @SSE2Loop: MOVDQA [R9], XMM0 ADD R9, 16 DEC RCX JNZ @SSE2Loop TEST RDX, RDX JZ @Exit @SmallLoop: MOV [R9], R8D ADD R9, 4 DEC RDX JNZ @SmallLoop @Exit: {$ENDIF} end; {$ENDIF} procedure FillWord(var X; Count: Cardinal; Value: LongWord); {$IFDEF USENATIVECODE} var I: Integer; P: PWordArray; begin P := PWordArray(@X); for I := Count - 1 downto 0 do P[I] := Value; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX = X; EDX = Count; ECX = Value PUSH EDI MOV EDI,EAX // Point EDI to destination MOV EAX,ECX MOV ECX,EDX TEST ECX,ECX JZ @exit REP STOSW // Fill count words @exit: POP EDI {$ENDIF} {$IFDEF TARGET_x64} // ECX = X; EDX = Count; R8D = Value PUSH RDI MOV RDI,RCX // Point EDI to destination MOV EAX,R8D MOV ECX,EDX TEST ECX,ECX JZ @exit REP STOSW // Fill count words @exit: POP RDI {$ENDIF} {$ENDIF} end; procedure MoveLongword(const Source; var Dest; Count: Integer); {$IFDEF USEMOVE} begin Move(Source, Dest, Count shl 2); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX = Source; EDX = Dest; ECX = Count PUSH ESI PUSH EDI MOV ESI,EAX MOV EDI,EDX CMP EDI,ESI JE @exit REP MOVSD @exit: POP EDI POP ESI {$ENDIF} {$IFDEF TARGET_x64} // RCX = Source; RDX = Dest; R8 = Count PUSH RSI PUSH RDI MOV RSI,RCX MOV RDI,RDX MOV RCX,R8 CMP RDI,RSI JE @exit REP MOVSD @exit: POP RDI POP RSI {$ENDIF} {$ENDIF} end; procedure MoveWord(const Source; var Dest; Count: Integer); {$IFDEF USEMOVE} begin Move(Source, Dest, Count shl 1); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} // EAX = X; EDX = Count; ECX = Value PUSH ESI PUSH EDI MOV ESI,EAX MOV EDI,EDX MOV EAX,ECX CMP EDI,ESI JE @exit REP MOVSW @exit: POP EDI POP ESI {$ENDIF} {$IFDEF TARGET_x64} // ECX = X; EDX = Count; R8 = Value PUSH RSI PUSH RDI MOV RSI,RCX MOV RDI,RDX MOV RAX,R8 CMP RDI,RSI JE @exit REP MOVSW @exit: POP RDI POP RSI {$ENDIF} {$ENDIF} end; procedure Swap(var A, B: Pointer); var T: Pointer; begin T := A; A := B; B := T; end; procedure Swap(var A, B: Integer); var T: Integer; begin T := A; A := B; B := T; end; procedure Swap(var A, B: TFixed); var T: TFixed; begin T := A; A := B; B := T; end; procedure Swap(var A, B: TColor32); var T: TColor32; begin T := A; A := B; B := T; end; procedure Swap32(var A, B); var T: Integer; begin T := Integer(A); Integer(A) := Integer(B); Integer(B) := T; end; procedure TestSwap(var A, B: Integer); var T: Integer; begin if B < A then begin T := A; A := B; B := T; end; end; procedure TestSwap(var A, B: TFixed); var T: TFixed; begin if B < A then begin T := A; A := B; B := T; end; end; function TestClip(var A, B: Integer; const Size: Integer): Boolean; begin TestSwap(A, B); // now A = min(A,B) and B = max(A, B) if A < 0 then A := 0; if B >= Size then B := Size - 1; Result := B >= A; end; function TestClip(var A, B: Integer; const Start, Stop: Integer): Boolean; begin TestSwap(A, B); // now A = min(A,B) and B = max(A, B) if A < Start then A := Start; if B >= Stop then B := Stop - 1; Result := B >= A; end; function Constrain(const Value, Lo, Hi: Integer): Integer; {$IFDEF USENATIVECODE} begin if Value < Lo then Result := Lo else if Value > Hi then Result := Hi else Result := Value; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX MOV ECX,R8D {$ENDIF} CMP EDX,EAX CMOVG EAX,EDX CMP ECX,EAX CMOVL EAX,ECX {$ENDIF} end; function Constrain(const Value, Lo, Hi: Single): Single; overload; begin if Value < Lo then Result := Lo else if Value > Hi then Result := Hi else Result := Value; end; function SwapConstrain(const Value: Integer; Constrain1, Constrain2: Integer): Integer; begin TestSwap(Constrain1, Constrain2); if Value < Constrain1 then Result := Constrain1 else if Value > Constrain2 then Result := Constrain2 else Result := Value; end; function Max(const A, B, C: Integer): Integer; {$IFDEF USENATIVECODE} begin if A > B then Result := A else Result := B; if C > Result then Result := C; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV RAX,RCX MOV RCX,R8 {$ENDIF} CMP EDX,EAX CMOVG EAX,EDX CMP ECX,EAX CMOVG EAX,ECX {$ENDIF} end; function Min(const A, B, C: Integer): Integer; {$IFDEF USENATIVECODE} begin if A < B then Result := A else Result := B; if C < Result then Result := C; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV RAX,RCX MOV RCX,R8 {$ENDIF} CMP EDX,EAX CMOVL EAX,EDX CMP ECX,EAX CMOVL EAX,ECX {$ENDIF} end; function Clamp(Value, Max: Integer): Integer; {$IFDEF USENATIVECODE} begin if Value > Max then Result := Max else if Value < 0 then Result := 0 else Result := Value; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX MOV ECX,R8D {$ENDIF} CMP EAX,EDX JG @Above TEST EAX,EAX JL @Below RET @Above: MOV EAX,EDX RET @Below: MOV EAX,0 RET {$ENDIF} end; function Clamp(Value, Min, Max: Integer): Integer; {$IFDEF USENATIVECODE} begin if Value > Max then Result := Max else if Value < Min then Result := Min else Result := Value; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX MOV ECX,R8D {$ENDIF} CMP EDX,EAX CMOVG EAX,EDX CMP ECX,EAX CMOVL EAX,ECX {$ENDIF} end; function Wrap(Value, Max: Integer): Integer; {$IFDEF USENATIVECODE} begin if Value < 0 then Result := Max + (Value - Max) mod (Max + 1) else Result := Value mod (Max + 1); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX MOV ECX,R8D LEA ECX,[RDX+1] {$ELSE} LEA ECX,[EDX+1] {$ENDIF} CDQ IDIV ECX MOV EAX,EDX TEST EAX,EAX JNL @Exit ADD EAX,ECX @Exit: {$ENDIF} end; function Wrap(Value, Min, Max: Integer): Integer; begin if Value < Min then Result := Max + (Value - Max) mod (Max - Min + 1) else Result := Min + (Value - Min) mod (Max - Min + 1); end; function Wrap(Value, Max: Single): Single; begin {$IFDEF USEFLOATMOD} Result := FloatMod(Value, Max); {$ELSE} Result := Value; while Result >= Max do Result := Result - Max; while Result < 0 do Result := Result + Max; {$ENDIF} end; function DivMod(Dividend, Divisor: Integer; out Remainder: Integer): Integer; {$IFDEF USENATIVECODE} begin Remainder := Dividend mod Divisor; Result := Dividend div Divisor; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} PUSH EBX MOV EBX,EDX CDQ IDIV EBX MOV [ECX],EDX POP EBX {$ENDIF} {$IFDEF TARGET_x64} PUSH RBX MOV EAX,ECX MOV ECX,R8D MOV EBX,EDX CDQ IDIV EBX MOV [RCX],EDX POP RBX {$ENDIF} {$ENDIF} end; function Mirror(Value, Max: Integer): Integer; {$IFDEF USENATIVECODE} var DivResult: Integer; begin if Value < 0 then begin DivResult := DivMod(Value - Max, Max + 1, Result); Inc(Result, Max); end else DivResult := DivMod(Value, Max + 1, Result); if Odd(DivResult) then Result := Max - Result; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX MOV ECX,R8D {$ENDIF} TEST EAX,EAX JNL @@1 NEG EAX @@1: MOV ECX,EDX CDQ IDIV ECX TEST EAX,1 MOV EAX,EDX JZ @Exit NEG EAX ADD EAX,ECX @Exit: {$ENDIF} end; function Mirror(Value, Min, Max: Integer): Integer; var DivResult: Integer; begin if Value < Min then begin DivResult := DivMod(Value - Max, Max - Min + 1, Result); Inc(Result, Max); end else begin DivResult := DivMod(Value - Min, Max - Min + 1, Result); Inc(Result, Min); end; if Odd(DivResult) then Result := Max + Min - Result; end; function WrapPow2(Value, Max: Integer): Integer; overload; begin Result := Value and Max; end; function WrapPow2(Value, Min, Max: Integer): Integer; overload; begin Result := (Value - Min) and (Max - Min) + Min; end; function MirrorPow2(Value, Max: Integer): Integer; overload; begin if Value and (Max + 1) = 0 then Result := Value and Max else Result := Max - Value and Max; end; function MirrorPow2(Value, Min, Max: Integer): Integer; overload; begin Value := Value - Min; Result := Max - Min; if Value and (Result + 1) = 0 then Result := Min + Value and Result else Result := Max - Value and Result; end; function GetOptimalWrap(Max: Integer): TWrapProc; overload; begin if (Max >= 0) and IsPowerOf2(Max + 1) then Result := WrapPow2 else Result := Wrap; end; function GetOptimalWrap(Min, Max: Integer): TWrapProcEx; overload; begin if (Min >= 0) and (Max >= Min) and IsPowerOf2(Max - Min + 1) then Result := WrapPow2 else Result := Wrap; end; function GetOptimalMirror(Max: Integer): TWrapProc; overload; begin if (Max >= 0) and IsPowerOf2(Max + 1) then Result := MirrorPow2 else Result := Mirror; end; function GetOptimalMirror(Min, Max: Integer): TWrapProcEx; overload; begin if (Min >= 0) and (Max >= Min) and IsPowerOf2(Max - Min + 1) then Result := MirrorPow2 else Result := Mirror; end; function GetWrapProc(WrapMode: TWrapMode): TWrapProc; overload; begin case WrapMode of wmRepeat: Result := Wrap; wmMirror: Result := Mirror; else //wmClamp: Result := Clamp; end; end; function GetWrapProc(WrapMode: TWrapMode; Max: Integer): TWrapProc; overload; begin case WrapMode of wmRepeat: Result := GetOptimalWrap(Max); wmMirror: Result := GetOptimalMirror(Max); else //wmClamp: Result := Clamp; end; end; function GetWrapProcEx(WrapMode: TWrapMode): TWrapProcEx; overload; begin case WrapMode of wmRepeat: Result := Wrap; wmMirror: Result := Mirror; else //wmClamp: Result := Clamp; end; end; function GetWrapProcEx(WrapMode: TWrapMode; Min, Max: Integer): TWrapProcEx; overload; begin case WrapMode of wmRepeat: Result := GetOptimalWrap(Min, Max); wmMirror: Result := GetOptimalMirror(Min, Max); else //wmClamp: Result := Clamp; end; end; function Div255(Value: Cardinal): Cardinal; begin Result := (Value * $8081) shr 23; end; { shift right with sign conservation } function SAR_3(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 8; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,3 {$ENDIF} end; function SAR_4(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 16; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,4 {$ENDIF} end; function SAR_6(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 64; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,6 {$ENDIF} end; function SAR_8(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 256; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,8 {$ENDIF} end; function SAR_9(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 512; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,9 {$ENDIF} end; function SAR_11(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 2048; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,11 {$ENDIF} end; function SAR_12(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 4096; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,12 {$ENDIF} end; function SAR_13(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 8192; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,13 {$ENDIF} end; function SAR_14(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 16384; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,14 {$ENDIF} end; function SAR_15(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 32768; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,15 {$ENDIF} end; function SAR_16(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Value div 65536; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} SAR EAX,16 {$ENDIF} end; { Colorswap exchanges ARGB <-> ABGR and fill A with $FF } function ColorSwap(WinColor: TColor): TColor32; {$IFDEF USENATIVECODE} var WCEn: TColor32Entry absolute WinColor; REn : TColor32Entry absolute Result; begin Result := WCEn.ARGB; REn.A := $FF; REn.R := WCEn.B; REn.B := WCEn.R; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm // EAX = WinColor // this function swaps R and B bytes in ABGR // and writes $FF into A component {$IFDEF TARGET_x64} MOV EAX,ECX {$ENDIF} BSWAP EAX MOV AL, $FF ROR EAX,8 {$ENDIF} end; {$IFDEF USESTACKALLOC} {$IFDEF PUREPASCAL} function StackAlloc(Size: Integer): Pointer; begin GetMem(Result, Size); end; procedure StackFree(P: Pointer); begin FreeMem(P); end; {$ELSE} { StackAlloc allocates a 'small' block of memory from the stack by decrementing SP. This provides the allocation speed of a local variable, but the runtime size flexibility of heap allocated memory. x64 implementation by Jameel Halabi } function StackAlloc(Size: Integer): Pointer; register; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} POP ECX // return address MOV EDX, ESP ADD EAX, 3 AND EAX, not 3 // round up to keep ESP dword aligned CMP EAX, 4092 JLE @@2 @@1: SUB ESP, 4092 PUSH EAX // make sure we touch guard page, to grow stack SUB EAX, 4096 JNS @@1 ADD EAX, 4096 @@2: SUB ESP, EAX MOV EAX, ESP // function result = low memory address of block PUSH EDX // save original SP, for cleanup MOV EDX, ESP SUB EDX, 4 PUSH EDX // save current SP, for sanity check (sp = [sp]) PUSH ECX // return to caller {$ENDIF} {$IFDEF TARGET_x64} {$IFNDEF FPC} .NOFRAME {$ENDIF} POP R8 // return address MOV RDX, RSP // original SP ADD ECX, 15 AND ECX, NOT 15 // round up to keep SP dqword aligned CMP ECX, 4088 JLE @@2 @@1: SUB RSP, 4088 PUSH RCX // make sure we touch guard page, to grow stack SUB ECX, 4096 JNS @@1 ADD ECX, 4096 @@2: SUB RSP, RCX MOV RAX, RSP // function result = low memory address of block PUSH RDX // save original SP, for cleanup MOV RDX, RSP SUB RDX, 8 PUSH RDX // save current SP, for sanity check (sp = [sp]) PUSH R8 // return to caller {$ENDIF} end; { StackFree pops the memory allocated by StackAlloc off the stack. - Calling StackFree is optional - SP will be restored when the calling routine exits, but it's a good idea to free the stack allocated memory ASAP anyway. - StackFree must be called in the same stack context as StackAlloc - not in a subroutine or finally block. - Multiple StackFree calls must occur in reverse order of their corresponding StackAlloc calls. - Built-in sanity checks guarantee that an improper call to StackFree will not corrupt the stack. Worst case is that the stack block is not released until the calling routine exits. } procedure StackFree(P: Pointer); register; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} POP ECX // return address MOV EDX, DWORD PTR [ESP] SUB EAX, 8 CMP EDX, ESP // sanity check #1 (SP = [SP]) JNE @Exit CMP EDX, EAX // sanity check #2 (P = this stack block) JNE @Exit MOV ESP, DWORD PTR [ESP+4] // restore previous SP @Exit: PUSH ECX // return to caller {$ENDIF} {$IFDEF TARGET_x64} {$IFNDEF FPC} .NOFRAME {$ENDIF} POP R8 // return address MOV RDX, QWORD PTR [RSP] SUB RCX, 16 CMP RDX, RSP // sanity check #1 (SP = [SP]) JNE @Exit CMP RDX, RCX // sanity check #2 (P = this stack block) JNE @Exit MOV RSP, QWORD PTR [RSP + 8] // restore previous SP @Exit: PUSH R8 // return to caller {$ENDIF} end; {$ENDIF} {$ENDIF} {CPU target and feature Function templates} const FID_FILLLONGWORD = 0; {Complete collection of unit templates} var Registry: TFunctionRegistry; procedure RegisterBindings; begin Registry := NewRegistry('GR32_LowLevel bindings'); Registry.RegisterBinding(FID_FILLLONGWORD, @@FillLongWord); Registry.Add(FID_FILLLONGWORD, @FillLongWord_Pas, []); {$IFNDEF PUREPASCAL} Registry.Add(FID_FILLLONGWORD, @FillLongWord_ASM, []); Registry.Add(FID_FILLLONGWORD, @FillLongWord_MMX, [ciMMX]); Registry.Add(FID_FILLLONGWORD, @FillLongword_SSE2, [ciSSE2]); {$ENDIF} Registry.RebindAll; end; initialization RegisterBindings; end. |
Added src/graphics32/GR32_Math.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 | unit GR32_Math; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Additional Math Routines for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * (parts of this unit were moved here from GR32_System.pas and GR32.pas by Alex A. Denisov) * * Portions created by the Initial Developer are Copyright (C) 2005-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Michael Hansen <dyster_tid@hotmail.com> * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses GR32; { Fixed point math routines } function FixedFloor(A: TFixed): Integer; function FixedCeil(A: TFixed): Integer; function FixedMul(A, B: TFixed): TFixed; function FixedDiv(A, B: TFixed): TFixed; function OneOver(Value: TFixed): TFixed; function FixedRound(A: TFixed): Integer; function FixedSqr(Value: TFixed): TFixed; function FixedSqrtLP(Value: TFixed): TFixed; // 8-bit precision function FixedSqrtHP(Value: TFixed): TFixed; // 16-bit precision // Fixed point interpolation function FixedCombine(W, X, Y: TFixed): TFixed; { Trigonometric routines } procedure SinCos(const Theta: TFloat; out Sin, Cos: TFloat); overload; procedure SinCos(const Theta, Radius: Single; out Sin, Cos: Single); overload; procedure SinCos(const Theta, ScaleX, ScaleY: TFloat; out Sin, Cos: Single); overload; function Hypot(const X, Y: TFloat): TFloat; overload; function Hypot(const X, Y: Integer): Integer; overload; function FastSqrt(const Value: TFloat): TFloat; function FastSqrtBab1(const Value: TFloat): TFloat; function FastSqrtBab2(const Value: TFloat): TFloat; function FastInvSqrt(const Value: Single): Single; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} overload; { Misc. Routines } { MulDiv a faster implementation of Windows.MulDiv funtion } function MulDiv(Multiplicand, Multiplier, Divisor: Integer): Integer; // tells if X is a power of 2, returns true when X = 1,2,4,8,16 etc. function IsPowerOf2(Value: Integer): Boolean; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} // returns X rounded down to the nearest power of two function PrevPowerOf2(Value: Integer): Integer; // returns X rounded down to the nearest power of two, i.e. 5 -> 8, 7 -> 8, 15 -> 16 function NextPowerOf2(Value: Integer): Integer; // fast average without overflow, useful for e.g. fixed point math function Average(A, B: Integer): Integer; // fast sign function function Sign(Value: Integer): Integer; function FloatMod(x, y: Double): Double; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function DivMod(Dividend, Divisor: Integer; var Remainder: Integer): Integer; {$IFDEF FPC} {$IFDEF TARGET_X64} (* FPC has no similar {$EXCESSPRECISION OFF} directive, but we can easily emulate that by overriding some internal math functions *) function PI: Single; [internproc: fpc_in_pi_real]; //function Abs(D: Single): Single; [internproc: fpc_in_abs_real]; //function Sqr(D: Single): Single; [internproc: fpc_in_sqr_real]; function Sqrt(D: Single): Single; [internproc: fpc_in_sqrt_real]; function ArcTan(D: Single): Single; [internproc: fpc_in_arctan_real]; function Ln(D: Single): Single; [internproc: fpc_in_ln_real]; function Sin(D: Single): Single; [internproc: fpc_in_sin_real]; function Cos(D: Single): Single; [internproc: fpc_in_cos_real]; function Exp(D: Single): Single; [internproc: fpc_in_exp_real]; function Round(D: Single): Int64; [internproc: fpc_in_round_real]; function Frac(D: Single): Single; [internproc: fpc_in_frac_real]; function Int(D: Single): Single; [internproc: fpc_in_int_real]; function Trunc(D: Single): Int64; [internproc: fpc_in_trunc_real]; function Ceil(X: Single): Integer; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function Floor(X: Single): Integer; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} {$ENDIF} {$ENDIF} type TCumSumProc = procedure(Values: PSingleArray; Count: Integer); var CumSum: TCumSumProc; implementation uses Math, GR32_System; {$IFDEF PUREPASCAL} const FixedOneS: Single = 65536; {$ENDIF} {$IFDEF FPC} {$IFDEF TARGET_X64} function Ceil(X: Single): Integer; begin Result := Trunc(X); if (X - Result) > 0 then Inc(Result); end; function Floor(X: Single): Integer; begin Result := Trunc(X); if (X - Result) < 0 then Dec(Result); end; {$ENDIF} {$ENDIF} { Fixed-point math } function FixedFloor(A: TFixed): Integer; {$IFDEF PUREPASCAL} begin Result := A div FIXEDONE; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} SAR EAX, 16 {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, ECX SAR EAX, 16 {$ENDIF} {$ENDIF} end; function FixedCeil(A: TFixed): Integer; {$IFDEF PUREPASCAL} begin Result := (A + $FFFF) div FIXEDONE; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} ADD EAX, $0000FFFF SAR EAX, 16 {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, ECX ADD EAX, $0000FFFF SAR EAX, 16 {$ENDIF} {$ENDIF} end; function FixedRound(A: TFixed): Integer; {$IFDEF PUREPASCAL} begin Result := (A + $7FFF) div FIXEDONE; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} ADD EAX, $00007FFF SAR EAX, 16 {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, ECX ADD EAX, $00007FFF SAR EAX, 16 {$ENDIF} {$ENDIF} end; function FixedMul(A, B: TFixed): TFixed; {$IFDEF PUREPASCAL} begin Result := Round(A * FixedToFloat * B); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} IMUL EDX SHRD EAX, EDX, 16 {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, ECX IMUL EDX SHRD EAX, EDX, 16 {$ENDIF} {$ENDIF} end; function FixedDiv(A, B: TFixed): TFixed; {$IFDEF PUREPASCAL} begin Result := Round(A / B * FixedOne); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} MOV ECX, B CDQ SHLD EDX, EAX, 16 SHL EAX, 16 IDIV ECX {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, ECX MOV ECX, EDX CDQ SHLD EDX, EAX, 16 SHL EAX, 16 IDIV ECX {$ENDIF} {$ENDIF} end; function OneOver(Value: TFixed): TFixed; {$IFDEF PUREPASCAL} const Dividend: Single = 4294967296; // FixedOne * FixedOne begin Result := Round(Dividend / Value); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} MOV ECX, Value XOR EAX, EAX MOV EDX, 1 IDIV ECX {$ENDIF} {$IFDEF TARGET_x64} XOR EAX, EAX MOV EDX, 1 IDIV ECX {$ENDIF} {$ENDIF} end; function FixedSqr(Value: TFixed): TFixed; {$IFDEF PUREPASCAL} begin Result := Round(Value * FixedToFloat * Value); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} IMUL EAX SHRD EAX, EDX, 16 {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, Value IMUL EAX SHRD EAX, EDX, 16 {$ENDIF} {$ENDIF} end; function FixedSqrtLP(Value: TFixed): TFixed; {$IFDEF PUREPASCAL} begin Result := Round(Sqrt(Value * FixedOneS)); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} PUSH EBX MOV ECX, EAX XOR EAX, EAX MOV EBX, $40000000 @SqrtLP1: MOV EDX, ECX SUB EDX, EBX JL @SqrtLP2 SUB EDX, EAX JL @SqrtLP2 MOV ECX,EDX SHR EAX, 1 OR EAX, EBX SHR EBX, 2 JNZ @SqrtLP1 SHL EAX, 8 JMP @SqrtLP3 @SqrtLP2: SHR EAX, 1 SHR EBX, 2 JNZ @SqrtLP1 SHL EAX, 8 @SqrtLP3: POP EBX {$ENDIF} {$IFDEF TARGET_x64} PUSH RBX XOR EAX, EAX MOV EBX, $40000000 @SqrtLP1: MOV EDX, ECX SUB EDX, EBX JL @SqrtLP2 SUB EDX, EAX JL @SqrtLP2 MOV ECX,EDX SHR EAX, 1 OR EAX, EBX SHR EBX, 2 JNZ @SqrtLP1 SHL EAX, 8 JMP @SqrtLP3 @SqrtLP2: SHR EAX, 1 SHR EBX, 2 JNZ @SqrtLP1 SHL EAX, 8 @SqrtLP3: POP RBX {$ENDIF} {$ENDIF} end; function FixedSqrtHP(Value: TFixed): TFixed; {$IFDEF PUREPASCAL} begin Result := Round(Sqrt(Value * FixedOneS)); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} PUSH EBX MOV ECX, EAX XOR EAX, EAX MOV EBX, $40000000 @SqrtHP1: MOV EDX, ECX SUB EDX, EBX jb @SqrtHP2 SUB EDX, EAX jb @SqrtHP2 MOV ECX,EDX SHR EAX, 1 OR EAX, EBX SHR EBX, 2 JNZ @SqrtHP1 JZ @SqrtHP5 @SqrtHP2: SHR EAX, 1 SHR EBX, 2 JNZ @SqrtHP1 @SqrtHP5: MOV EBX, $00004000 SHL EAX, 16 SHL ECX, 16 @SqrtHP3: MOV EDX, ECX SUB EDX, EBX jb @SqrtHP4 SUB EDX, EAX jb @SqrtHP4 MOV ECX, EDX SHR EAX, 1 OR EAX, EBX SHR EBX, 2 JNZ @SqrtHP3 JMP @SqrtHP6 @SqrtHP4: SHR EAX, 1 SHR EBX, 2 JNZ @SqrtHP3 @SqrtHP6: POP EBX {$ENDIF} {$IFDEF TARGET_x64} PUSH RBX XOR EAX, EAX MOV EBX, $40000000 @SqrtHP1: MOV EDX, ECX SUB EDX, EBX jb @SqrtHP2 SUB EDX, EAX jb @SqrtHP2 MOV ECX,EDX SHR EAX, 1 OR EAX, EBX SHR EBX, 2 JNZ @SqrtHP1 JZ @SqrtHP5 @SqrtHP2: SHR EAX, 1 SHR EBX, 2 JNZ @SqrtHP1 @SqrtHP5: MOV EBX, $00004000 SHL EAX, 16 SHL ECX, 16 @SqrtHP3: MOV EDX, ECX SUB EDX, EBX jb @SqrtHP4 SUB EDX, EAX jb @SqrtHP4 MOV ECX, EDX SHR EAX, 1 OR EAX, EBX SHR EBX, 2 JNZ @SqrtHP3 JMP @SqrtHP6 @SqrtHP4: SHR EAX, 1 SHR EBX, 2 JNZ @SqrtHP3 @SqrtHP6: POP RBX {$ENDIF} {$ENDIF} end; function FixedCombine(W, X, Y: TFixed): TFixed; // EAX <- W, EDX <- X, ECX <- Y // combine fixed value X and fixed value Y with the weight of X given in W // Result Z = W * X + (1 - W) * Y = Y + (X - Y) * W // Fixed Point Version: Result Z = Y + (X - Y) * W / 65536 {$IFDEF PUREPASCAL} begin Result := Round(Y + (X - Y) * FixedToFloat * W); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} SUB EDX, ECX IMUL EDX SHRD EAX, EDX, 16 ADD EAX, ECX {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, ECX SUB EDX, R8D IMUL EDX SHRD EAX, EDX, 16 ADD EAX, R8D {$ENDIF} {$ENDIF} end; { Trigonometry } procedure SinCos(const Theta: TFloat; out Sin, Cos: TFloat); {$IFDEF NATIVE_SINCOS} var S, C: Extended; begin Math.SinCos(Theta, S, C); Sin := S; Cos := C; {$ELSE} {$IFDEF TARGET_x64} var Temp: TFloat; {$ENDIF} asm {$IFDEF TARGET_x86} FLD Theta FSINCOS FSTP DWORD PTR [EDX] // cosine FSTP DWORD PTR [EAX] // sine {$ENDIF} {$IFDEF TARGET_x64} MOVD Temp, Theta FLD Temp FSINCOS FSTP [Sin] // cosine FSTP [Cos] // sine {$ENDIF} {$ENDIF} end; procedure SinCos(const Theta, Radius: TFloat; out Sin, Cos: TFloat); {$IFDEF NATIVE_SINCOS} var S, C: Extended; begin Math.SinCos(Theta, S, C); Sin := S * Radius; Cos := C * Radius; {$ELSE} {$IFDEF TARGET_x64} var Temp: TFloat; {$ENDIF} asm {$IFDEF TARGET_x86} FLD Theta FSINCOS FMUL Radius FSTP DWORD PTR [EDX] // cosine FMUL Radius FSTP DWORD PTR [EAX] // sine {$ENDIF} {$IFDEF TARGET_x64} MOVD Temp, Theta FLD Temp MOVD Temp, Radius FSINCOS FMUL Temp FSTP [Cos] FMUL Temp FSTP [Sin] {$ENDIF} {$ENDIF} end; procedure SinCos(const Theta, ScaleX, ScaleY: TFloat; out Sin, Cos: Single); overload; {$IFDEF NATIVE_SINCOS} var S, C: Extended; begin Math.SinCos(Theta, S, C); Sin := S * ScaleX; Cos := C * ScaleY; {$ELSE} {$IFDEF TARGET_x64} var Temp: TFloat; {$ENDIF} asm {$IFDEF TARGET_x86} FLD Theta FSINCOS FMUL ScaleX FSTP DWORD PTR [EDX] // cosine FMUL ScaleY FSTP DWORD PTR [EAX] // sine {$ENDIF} {$IFDEF TARGET_x64} MOVD Temp, Theta FLD Temp FSINCOS MOVD Temp, ScaleX FMUL Temp FSTP [Cos] MOVD Temp, ScaleY FMUL Temp FSTP [Sin] {$ENDIF} {$ENDIF} end; function Hypot(const X, Y: TFloat): TFloat; {$IFDEF PUREPASCAL} begin Result := Sqrt(Sqr(X) + Sqr(Y)); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} FLD X FMUL ST,ST FLD Y FMUL ST,ST FADDP ST(1),ST FSQRT FWAIT {$ENDIF} {$IFDEF TARGET_x64} MULSS XMM0, XMM0 MULSS XMM1, XMM1 ADDSS XMM0, XMM1 SQRTSS XMM0, XMM0 {$ENDIF} {$ENDIF} end; function Hypot(const X, Y: Integer): Integer; //{$IFDEF PUREPASCAL} begin Result := Round(Math.Hypot(X, Y)); (* {$ELSE} asm {$IFDEF TARGET_x64} IMUL RAX, RCX, RDX {$ELSE} FLD X FMUL ST,ST FLD Y FMUL ST,ST FADDP ST(1),ST FSQRT FISTP [ESP - 4] MOV EAX, [ESP - 4] FWAIT {$ENDIF} {$ENDIF} *) end; function FastSqrt(const Value: TFloat): TFloat; // see http://en.wikipedia.org/wiki/Methods_of_computing_square_roots#Approximations_that_depend_on_IEEE_representation {$IFDEF PUREPASCAL} var I: Integer absolute Value; J: Integer absolute Result; begin J := (I - $3F800000) div 2 + $3F800000; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} MOV EAX, DWORD PTR Value SUB EAX, $3F800000 SAR EAX, 1 ADD EAX, $3F800000 MOV DWORD PTR [ESP - 4], EAX FLD DWORD PTR [ESP - 4] {$ENDIF} {$IFDEF TARGET_x64} SQRTSS XMM0, XMM0 {$ENDIF} {$ENDIF} end; function FastSqrtBab1(const Value: TFloat): TFloat; // see http://en.wikipedia.org/wiki/Methods_of_computing_square_roots#Approximations_that_depend_on_IEEE_representation // additionally one babylonian step added {$IFNDEF PUREPASCAL} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} {$ENDIF} const CHalf : TFloat = 0.5; {$IFDEF PUREPASCAL} var I: Integer absolute Value; J: Integer absolute Result; begin J := (I - $3F800000) div 2 + $3F800000; Result := CHalf * (Result + Value / Result); {$ELSE} asm {$IFDEF TARGET_x86} MOV EAX, Value SUB EAX, $3F800000 SAR EAX, 1 ADD EAX, $3F800000 MOV DWORD PTR [ESP - 4], EAX FLD Value FDIV DWORD PTR [ESP - 4] FADD DWORD PTR [ESP - 4] FMUL CHalf {$ENDIF} {$IFDEF TARGET_x64} SQRTSS XMM0, XMM0 {$ENDIF} {$ENDIF} end; function FastSqrtBab2(const Value: TFloat): TFloat; // see http://en.wikipedia.org/wiki/Methods_of_computing_square_roots#Approximations_that_depend_on_IEEE_representation // additionally two babylonian steps added {$IFDEF PUREPASCAL} const CQuarter : TFloat = 0.25; var J: Integer absolute Result; begin Result := Value; J := ((J - (1 shl 23)) shr 1) + (1 shl 29); Result := Result + Value / Result; Result := CQuarter * Result + Value / Result; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} const CHalf : TFloat = 0.5; asm {$IFDEF TARGET_x86} MOV EAX, Value SUB EAX, $3F800000 SAR EAX, 1 ADD EAX, $3F800000 MOV DWORD PTR [ESP - 4], EAX FLD Value FDIV DWORD PTR [ESP - 4] FADD DWORD PTR [ESP - 4] FMUL CHalf {$ENDIF} {$IFDEF TARGET_x64} MOVD EAX, Value SUB EAX, $3F800000 SAR EAX, 1 ADD EAX, $3F800000 MOVD XMM1, EAX DIVSS XMM0, XMM1 ADDSS XMM0, XMM1 MOVD XMM1, [RIP + CHalf] MULSS XMM0, XMM1 {$ENDIF} {$ENDIF} end; function FastInvSqrt(const Value: Single): Single; var IntCst : Cardinal absolute result; begin Result := Value; IntCst := ($BE6EB50C - IntCst) shr 1; Result := 0.5 * Result * (3 - Value * Sqr(Result)); end; { Misc. } function MulDiv(Multiplicand, Multiplier, Divisor: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Int64(Multiplicand) * Int64(Multiplier) div Divisor; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} PUSH EBX // Imperative save PUSH ESI // of EBX and ESI MOV EBX, EAX // Result will be negative or positive so set rounding direction XOR EBX, EDX // Negative: substract 1 in case of rounding XOR EBX, ECX // Positive: add 1 OR EAX, EAX // Make all operands positive, ready for unsigned operations JNS @m1Ok // minimizing branching NEG EAX @m1Ok: OR EDX, EDX JNS @m2Ok NEG EDX @m2Ok: OR ECX, ECX JNS @DivOk NEG ECX @DivOK: MUL EDX // Unsigned multiply (Multiplicand*Multiplier) MOV ESI, EDX // Check for overflow, by comparing SHL ESI, 1 // 2 times the high-order 32 bits of the product (EDX) CMP ESI, ECX // with the Divisor. JAE @Overfl // If equal or greater than overflow with division anticipated DIV ECX // Unsigned divide of product by Divisor SUB ECX, EDX // Check if the result must be adjusted by adding or substracting CMP ECX, EDX // 1 (*.5 -> nearest integer), by comparing the difference of JA @NoAdd // Divisor and remainder with the remainder. If it is greater then INC EAX // no rounding needed; add 1 to result otherwise @NoAdd: OR EBX, EDX // From unsigned operations back the to original sign of the result JNS @Exit // must be positive NEG EAX // must be negative JMP @Exit @Overfl: OR EAX, -1 // 3 bytes alternative for MOV EAX,-1. Windows.MulDiv "overflow" // and "zero-divide" return value @Exit: POP ESI // Restore POP EBX // esi and EBX {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, ECX // Result will be negative or positive so set rounding direction XOR ECX, EDX // Negative: substract 1 in case of rounding XOR ECX, R8D // Positive: add 1 OR EAX, EAX // Make all operands positive, ready for unsigned operations JNS @m1Ok // minimizing branching NEG EAX @m1Ok: OR EDX, EDX JNS @m2Ok NEG EDX @m2Ok: OR R8D, R8D JNS @DivOk NEG R8D @DivOK: MUL EDX // Unsigned multiply (Multiplicand*Multiplier) MOV R9D, EDX // Check for overflow, by comparing SHL R9D, 1 // 2 times the high-order 32 bits of the product (EDX) CMP R9D, R8D // with the Divisor. JAE @Overfl // If equal or greater than overflow with division anticipated DIV R8D // Unsigned divide of product by Divisor SUB R8D, EDX // Check if the result must be adjusted by adding or substracting CMP R8D, EDX // 1 (*.5 -> nearest integer), by comparing the difference of JA @NoAdd // Divisor and remainder with the remainder. If it is greater then INC EAX // no rounding needed; add 1 to result otherwise @NoAdd: OR ECX, EDX // From unsigned operations back the to original sign of the result JNS @Exit // must be positive NEG EAX // must be negative JMP @Exit @Overfl: OR EAX, -1 // 3 bytes alternative for MOV EAX,-1. Windows.MulDiv "overflow" // and "zero-divide" return value @Exit: {$ENDIF} {$ENDIF} end; function IsPowerOf2(Value: Integer): Boolean; //returns true when X = 1,2,4,8,16 etc. begin Result := Value and (Value - 1) = 0; end; function PrevPowerOf2(Value: Integer): Integer; //returns X rounded down to the power of two {$IFDEF PUREPASCAL} begin Result := 1; while Value shr 1 > 0 do Result := Result shl 1; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} BSR ECX, EAX SHR EAX, CL SHL EAX, CL {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, Value BSR ECX, EAX SHR EAX, CL SHL EAX, CL {$ENDIF} {$ENDIF} end; function NextPowerOf2(Value: Integer): Integer; //returns X rounded up to the power of two, i.e. 5 -> 8, 7 -> 8, 15 -> 16 {$IFDEF PUREPASCAL} begin Result := 2; while Value shr 1 > 0 do Result := Result shl 1; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} DEC EAX JLE @1 BSR ECX, EAX MOV EAX, 2 SHL EAX, CL RET @1: MOV EAX, 1 {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, Value DEC EAX JLE @1 BSR ECX, EAX MOV EAX, 2 SHL EAX, CL RET @1: MOV EAX, 1 {$ENDIF} {$ENDIF} end; function Average(A, B: Integer): Integer; //fast average without overflow, useful e.g. for fixed point math //(A + B)/2 = (A and B) + (A xor B)/2 {$IFDEF PUREPASCAL} begin Result := (A and B) + (A xor B) div 2; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} MOV ECX, EDX XOR EDX, EAX SAR EDX, 1 AND EAX, ECX ADD EAX, EDX {$ENDIF} {$IFDEF TARGET_x64} MOV EAX, A MOV ECX, EDX XOR EDX, EAX SAR EDX, 1 AND EAX, ECX ADD EAX, EDX {$ENDIF} {$ENDIF} end; function Sign(Value: Integer): Integer; {$IFDEF PUREPASCAL} begin //Assumes 32 bit integer Result := (- Value) shr 31 - (Value shr 31); {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x64} MOV EAX, Value {$ENDIF} CDQ NEG EAX ADC EDX, EDX MOV EAX, EDX {$ENDIF} end; function FloatMod(x, y: Double): Double; begin if (y = 0) then Result := X else Result := x - y * Floor(x / y); end; function DivMod(Dividend, Divisor: Integer; var Remainder: Integer): Integer; {$IFDEF PUREPASCAL} begin Result := Dividend div Divisor; Remainder := Dividend mod Divisor; {$ELSE} {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} PUSH EDX CDQ IDIV DWORD PTR [ESP] ADD ESP, $04 MOV DWORD PTR [ECX], edx {$ENDIF} {$IFDEF TARGET_x64} MOV RAX, RCX MOV R9, RDX CDQ IDIV R9 MOV DWORD PTR [R8], EDX {$ENDIF} {$ENDIF} end; procedure CumSum_Pas(Values: PSingleArray; Count: Integer); var I: Integer; V: TFloat; begin V := Values[0]; for I := 1 to Count - 1 do begin if PInteger(@Values[I])^ <> 0 then V := V + Values[I]; Values[I] := V; end; end; {$IFNDEF PUREPASCAL} // Aligned SSE2 version -- Credits: Sanyin <prevodilac@hotmail.com> procedure CumSum_SSE2(Values: PSingleArray; Count: Integer); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} asm {$IFDEF TARGET_x86} MOV ECX,EDX CMP ECX,2 // if count < 2, exit JL @END CMP ECX,32 // if count < 32, avoid SSE2 overhead JL @SMALL {--- align memory ---} PUSH EBX PXOR XMM4,XMM4 MOV EBX,EAX AND EBX,15 // get aligned count JZ @ENDALIGNING // already aligned ADD EBX,-16 NEG EBX // get bytes to advance JZ @ENDALIGNING // already aligned MOV ECX,EBX SAR ECX,2 // div with 4 to get cnt SUB EDX,ECX ADD EAX,4 DEC ECX JZ @SETUPLAST // one element @ALIGNINGLOOP: FLD DWORD PTR [EAX-4] FADD DWORD PTR [EAX] FSTP DWORD PTR [EAX] ADD EAX,4 DEC ECX JNZ @ALIGNINGLOOP @SETUPLAST: MOVUPS XMM4,[EAX-4] PSLLDQ XMM4,12 PSRLDQ XMM4,12 @ENDALIGNING: POP EBX PUSH EBX MOV ECX,EDX SAR ECX,2 @LOOP: MOVAPS XMM0,[EAX] PXOR XMM5,XMM5 PCMPEQD XMM5,XMM0 PMOVMSKB EBX,XMM5 CMP EBX,$0000FFFF JNE @NORMAL PSHUFD XMM0,XMM4,0 JMP @SKIP @NORMAL: ADDPS XMM0,XMM4 PSHUFD XMM1,XMM0,$e4 PSLLDQ XMM1,4 PSHUFD XMM2,XMM1,$90 PSHUFD XMM3,XMM1,$40 ADDPS XMM2,XMM3 ADDPS XMM1,XMM2 ADDPS XMM0,XMM1 PSHUFLW XMM4,XMM0,$E4 PSRLDQ XMM4,12 @SKIP: PREFETCHNTA [eax+16*16*2] MOVAPS [EAX],XMM0 ADD EAX,16 SUB ECX,1 JNZ @LOOP POP EBX MOV ECX,EDX SAR ECX,2 SHL ECX,2 SUB EDX,ECX MOV ECX,EDX JZ @END @LOOP2: FLD DWORD PTR [EAX-4] FADD DWORD PTR [EAX] FSTP DWORD PTR [EAX] ADD EAX,4 DEC ECX JNZ @LOOP2 JMP @END @SMALL: MOV ECX,EDX ADD EAX,4 DEC ECX @LOOP3: FLD DWORD PTR [EAX-4] FADD DWORD PTR [EAX] FSTP DWORD PTR [EAX] ADD EAX,4 DEC ECX JNZ @LOOP3 {$ENDIF} {$IFDEF TARGET_x64} CMP EDX,2 // if count < 2, exit JL @END MOV RAX,RCX MOV ECX,EDX CMP ECX,32 // if count < 32, avoid SSE2 overhead JL @SMALL {--- align memory ---} PXOR XMM4,XMM4 MOV R8D,EAX AND R8D,15 // get aligned count JZ @ENDALIGNING // already aligned ADD R8D,-16 NEG R8D // get bytes to advance JZ @ENDALIGNING // already aligned MOV ECX,R8D SAR ECX,2 // div with 4 to get cnt SUB EDX,ECX ADD RAX,4 DEC ECX JZ @SETUPLAST // one element @ALIGNINGLOOP: FLD DWORD PTR [RAX - 4] FADD DWORD PTR [RAX] FSTP DWORD PTR [RAX] ADD RAX,4 DEC ECX JNZ @ALIGNINGLOOP @SETUPLAST: MOVUPS XMM4,[RAX - 4] PSLLDQ XMM4,12 PSRLDQ XMM4,12 @ENDALIGNING: MOV ECX,EDX SAR ECX,2 @LOOP: MOVAPS XMM0,[RAX] PXOR XMM5,XMM5 PCMPEQD XMM5,XMM0 PMOVMSKB R8D,XMM5 CMP R8D,$0000FFFF JNE @NORMAL PSHUFD XMM0,XMM4,0 JMP @SKIP @NORMAL: ADDPS XMM0,XMM4 PSHUFD XMM1,XMM0,$e4 PSLLDQ XMM1,4 PSHUFD XMM2,XMM1,$90 PSHUFD XMM3,XMM1,$40 ADDPS XMM2,XMM3 ADDPS XMM1,XMM2 ADDPS XMM0,XMM1 PSHUFLW XMM4,XMM0,$E4 PSRLDQ XMM4,12 @SKIP: PREFETCHNTA [RAX + 32 * 2] MOVAPS [RAX],XMM0 ADD RAX,16 SUB ECX,1 JNZ @LOOP MOV ECX,EDX SAR ECX,2 SHL ECX,2 SUB EDX,ECX MOV ECX,EDX JZ @END @LOOP2: FLD DWORD PTR [RAX - 4] FADD DWORD PTR [RAX] FSTP DWORD PTR [RAX] ADD RAX,4 DEC ECX JNZ @LOOP2 JMP @END @SMALL: ADD RAX,4 DEC ECX @LOOP3: FLD DWORD PTR [RAX - 4] FADD DWORD PTR [RAX] FSTP DWORD PTR [RAX] ADD RAX,4 DEC ECX JNZ @LOOP3 {$ENDIF} @END: end; {$ENDIF} initialization {$IFNDEF PUREPASCAL} if HasInstructionSet(ciSSE2) then CumSum := CumSum_SSE2 else {$ENDIF} CumSum := CumSum_Pas; end. |
Added src/graphics32/GR32_MicroTiles.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 | unit GR32_MicroTiles; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is MicroTiles Repaint Optimizer Extension for Graphics32 * * The Initial Developer of the Original Code is * Andre Beckedorf - metaException * Andre@metaException.de * * Portions created by the Initial Developer are Copyright (C) 2005-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} {-$DEFINE CODESITE} {-$DEFINE CODESITE_HIGH} {-$DEFINE PROFILINGDRYRUN} {-$DEFINE MICROTILES_DEBUGDRAW} {-$DEFINE MICROTILES_DEBUGDRAW_RANDOM_COLORS} {-$DEFINE MICROTILES_DEBUGDRAW_UNOPTIMIZED} {-$DEFINE MICROTILES_NO_ADAPTION} {-$DEFINE MICROTILES_NO_ADAPTION_FORCE_WHOLETILES} uses {$IFDEF FPC} Types, {$IFDEF Windows} Windows, {$ENDIF} {$ELSE} Windows, {$ENDIF} {$IFDEF CODESITE} CSIntf, CSAux, {$ENDIF} {$IFDEF COMPILER2005_UP} Types, {$ENDIF} SysUtils, Classes, GR32, GR32_System, GR32_Containers, GR32_Layers, GR32_RepaintOpt; const MICROTILE_SHIFT = 5; MICROTILE_SIZE = 1 shl MICROTILE_SHIFT; MICROTILE_EMPTY = 0; // MICROTILE_EMPTY -> Left: 0, Top: 0, Right: 0, Bottom: 0 MICROTILE_FULL = MICROTILE_SIZE shl 8 or MICROTILE_SIZE; // MICROTILE_FULL -> Left: 0, Top: 0, Right: MICROTILE_SIZE, Bottom: MICROTILE_SIZE MicroTileSize = MaxInt div 16; {$IFDEF MICROTILES_DEBUGDRAW} clDebugDrawFill = TColor32($30FF0000); clDebugDrawFrame = TColor32($90FF0000); {$ENDIF} type PMicroTile = ^TMicroTile; TMicroTile = type Integer; PMicroTileArray = ^TMicroTileArray; TMicroTileArray = array[0..MicroTileSize - 1] of TMicroTile; PPMicroTiles = ^PMicroTiles; PMicroTiles = ^TMicroTiles; TMicroTiles = record BoundsRect: TRect; Columns, Rows: Integer; BoundsUsedTiles: TRect; Count: Integer; Tiles: PMicroTileArray; end; // MicroTile auxiliary routines function MakeMicroTile(const Left, Top, Right, Bottom: Integer): TMicroTile; {$IFDEF USEINLINING} inline; {$ENDIF} function MicroTileHeight(const Tile: TMicroTile): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} function MicroTileWidth(const Tile: TMicroTile): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} var MicroTileUnion: procedure(var DstTile: TMicroTile; const SrcTile: TMicroTile); // MicroTiles auxiliary routines function MakeEmptyMicroTiles: TMicroTiles; {$IFDEF USEINLINING} inline; {$ENDIF} procedure MicroTilesCreate(var MicroTiles: TMicroTiles); {$IFDEF USEINLINING} inline; {$ENDIF} procedure MicroTilesDestroy(var MicroTiles: TMicroTiles); {$IFDEF USEINLINING} inline; {$ENDIF} procedure MicroTilesSetSize(var MicroTiles: TMicroTiles; const DstRect: TRect); procedure MicroTilesClear(var MicroTiles: TMicroTiles; const Value: TMicroTile = MICROTILE_EMPTY); {$IFDEF USEINLINING} inline; {$ENDIF} procedure MicroTilesClearUsed(var MicroTiles: TMicroTiles; const Value: TMicroTile = MICROTILE_EMPTY); procedure MicroTilesCopy(var DstTiles: TMicroTiles; SrcTiles: TMicroTiles); procedure MicroTilesAddLine(var MicroTiles: TMicroTiles; X1, Y1, X2, Y2: Integer; LineWidth: Integer; RoundToWholeTiles: Boolean = False); procedure MicroTilesAddRect(var MicroTiles: TMicroTiles; Rect: TRect; RoundToWholeTiles: Boolean = False); procedure MicroTilesUnion(var DstTiles: TMicroTiles; const SrcTiles: TMicroTiles; RoundToWholeTiles: Boolean = False); function MicroTilesCalcRects(const MicroTiles: TMicroTiles; DstRects: TRectList; CountOnly: Boolean = False; RoundToWholeTiles: Boolean = False): Integer; overload; function MicroTilesCalcRects(const MicroTiles: TMicroTiles; DstRects: TRectList; const Clip: TRect; CountOnly: Boolean = False; RoundToWholeTiles: Boolean = False): Integer; overload; function MicroTilesCountEmptyTiles(const MicroTiles: TMicroTiles): Integer; type { TMicroTilesMap } { associative array that is used to map Layers to their MicroTiles } TMicroTilesMap = class(TPointerMap) private function GetData(Item: Pointer): PMicroTiles; procedure SetData(Item: Pointer; const Data: PMicroTiles); protected function Delete(BucketIndex: Integer; ItemIndex: Integer): Pointer; override; public function Add(Item: Pointer): PPMicroTiles; property Data[Item: Pointer]: PMicroTiles read GetData write SetData; default; end; type { TMicroTilesRepaintOptimizer } { Repaint manager that optimizes the repaint process using MicroTiles } TMicroTilesRepaintOptimizer = class(TCustomRepaintOptimizer) private // working tiles FBufferBounds: TRect; FWorkMicroTiles: PMicroTiles; // used by DrawLayerToMicroTiles FTempTiles: TMicroTiles; FInvalidTiles: TMicroTiles; FForcedInvalidTiles: TMicroTiles; // list of invalid layers FInvalidLayers: TList; // association that maps layers to their old invalid tiles FOldInvalidTilesMap: TMicroTilesMap; FWorkingTilesValid: Boolean; FOldInvalidTilesValid: Boolean; FUseInvalidTiles: Boolean; // adaptive stuff... FAdaptiveMode: Boolean; FPerfTimer: TPerfTimer; FPerformanceLevel: Integer; FElapsedTimeForLastRepaint: Int64; FElapsedTimeForFullSceneRepaint: Int64; FAdaptionFailed: Boolean; // vars for time based approach FTimedCheck: Boolean; FTimeDelta: Integer; FNextCheck: Integer; FElapsedTimeOnLastPenalty: Int64; // vars for invalid rect difference approach FOldInvalidRectsCount: Integer; {$IFDEF MICROTILES_DEBUGDRAW} FDebugWholeTiles: Boolean; FDebugMicroTiles: TMicroTiles; FDebugInvalidRects: TRectList; {$ENDIF} procedure DrawLayerToMicroTiles(var DstTiles: TMicroTiles; Layer: TCustomLayer); procedure DrawMeasuringHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); procedure ValidateWorkingTiles; procedure UpdateOldInvalidTiles; procedure SetAdaptiveMode(const Value: Boolean); procedure ResetAdaptiveMode; procedure BeginAdaption; procedure EndAdaption; procedure AddArea(var Tiles: TMicroTiles; const Area: TRect; const Info: Cardinal); protected procedure SetEnabled(const Value: Boolean); override; // LayerCollection handler procedure LayerCollectionNotifyHandler(Sender: TLayerCollection; Action: TLayerListNotification; Layer: TCustomLayer; Index: Integer); override; public constructor Create(Buffer: TBitmap32; InvalidRects: TRectList); override; destructor Destroy; override; procedure RegisterLayerCollection(Layers: TLayerCollection); override; procedure UnregisterLayerCollection(Layers: TLayerCollection); override; procedure Reset; override; function UpdatesAvailable: Boolean; override; procedure PerformOptimization; override; procedure BeginPaintBuffer; override; procedure EndPaintBuffer; override; // handlers procedure AreaUpdateHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); override; procedure LayerUpdateHandler(Sender: TObject; Layer: TCustomLayer); override; procedure BufferResizedHandler(const NewWidth, NewHeight: Integer); override; // custom settings: property AdaptiveMode: Boolean read FAdaptiveMode write SetAdaptiveMode; end; {$IFDEF CODESITE} TDebugMicroTilesRepaintOptimizer = class(TMicroTilesRepaintOptimizer) public procedure Reset; override; function UpdatesAvailable: Boolean; override; procedure PerformOptimization; override; procedure BeginPaintBuffer; override; procedure EndPaintBuffer; override; procedure AreaUpdateHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); override; procedure LayerUpdateHandler(Sender: TObject; Layer: TCustomLayer); override; procedure BufferResizedHandler(const NewWidth, NewHeight: Integer); override; end; {$ENDIF} implementation uses GR32_Bindings, GR32_LowLevel, GR32_Math, Math; var MicroTilesU: procedure(var DstTiles: TMicroTiles; const SrcTiles: TMicroTiles); { MicroTile auxiliary routines } function MakeMicroTile(const Left, Top, Right, Bottom: Integer): TMicroTile; begin Result := Left shl 24 or Top shl 16 or Right shl 8 or Bottom; end; function MicroTileHeight(const Tile: TMicroTile): Integer; begin Result := (Tile and $FF) - (Tile shr 16 and $FF); end; function MicroTileWidth(const Tile: TMicroTile): Integer; begin Result := (Tile shr 8 and $FF) - (Tile shr 24); end; procedure MicroTileUnion_Pas(var DstTile: TMicroTile; const SrcTile: TMicroTile); var SrcLeft, SrcTop, SrcRight, SrcBottom: Integer; begin SrcLeft := SrcTile shr 24; SrcTop := (SrcTile and $FF0000) shr 16; SrcRight := (SrcTile and $FF00) shr 8; SrcBottom := SrcTile and $FF; if (DstTile <> MICROTILE_FULL) and (SrcTile <> MICROTILE_EMPTY) and (SrcRight - SrcLeft <> 0) and (SrcBottom - SrcTop <> 0) then begin if (DstTile = MICROTILE_EMPTY) or (SrcTile = MICROTILE_FULL) then DstTile := SrcTile else begin DstTile := Min(DstTile shr 24, SrcLeft) shl 24 or Min(DstTile shr 16 and $FF, SrcTop) shl 16 or Max(DstTile shr 8 and $FF, SrcRight) shl 8 or Max(DstTile and $FF, SrcBottom); end; end; end; {$IFDEF TARGET_x86} procedure MicroTileUnion_EMMX(var DstTile: TMicroTile; const SrcTile: TMicroTile); var SrcLeft, SrcTop, SrcRight, SrcBottom: Integer; begin SrcLeft := SrcTile shr 24; SrcTop := (SrcTile and $FF0000) shr 16; SrcRight := (SrcTile and $FF00) shr 8; SrcBottom := SrcTile and $FF; if (DstTile <> MICROTILE_FULL) and (SrcTile <> MICROTILE_EMPTY) and (SrcRight - SrcLeft <> 0) and (SrcBottom - SrcTop <> 0) then begin if (DstTile = MICROTILE_EMPTY) or (SrcTile = MICROTILE_FULL) then DstTile := SrcTile else asm MOVD MM1,[SrcTile] MOV EAX,[DstTile] MOVD MM2, [EAX] MOVQ MM3, MM1 MOV ECX,$FFFF0000 // Mask MOVD MM0, ECX PMINUB MM1, MM2 PAND MM1, MM0 PSRLD MM0, 16 // shift mask right by 16 bits PMAXUB MM2, MM3 PAND MM2, MM0 POR MM1, MM2 MOVD [EAX], MM1 EMMS end; end; end; {$ENDIF} { MicroTiles auxiliary routines } function MakeEmptyMicroTiles: TMicroTiles; begin FillChar(Result, SizeOf(TMicroTiles), 0); ReallocMem(Result.Tiles, 0); end; procedure MicroTilesCreate(var MicroTiles: TMicroTiles); begin FillChar(MicroTiles, SizeOf(TMicroTiles), 0); ReallocMem(MicroTiles.Tiles, 0); end; procedure MicroTilesDestroy(var MicroTiles: TMicroTiles); begin ReallocMem(MicroTiles.Tiles, 0); end; procedure MicroTilesSetSize(var MicroTiles: TMicroTiles; const DstRect: TRect); begin MicroTiles.BoundsRect := DstRect; MicroTiles.Columns := ((DstRect.Right - DstRect.Left) shr MICROTILE_SHIFT) + 1; MicroTiles.Rows := ((DstRect.Bottom - DstRect.Top) shr MICROTILE_SHIFT) + 1; MicroTiles.Count := (MicroTiles.Columns + 1) * (MicroTiles.Rows + 1); ReallocMem(MicroTiles.Tiles, MicroTiles.Count * SizeOf(TMicroTile)); MicroTilesClear(MicroTiles) end; procedure MicroTilesClear(var MicroTiles: TMicroTiles; const Value: TMicroTile); begin MicroTiles.BoundsUsedTiles := MakeRect(MicroTiles.Columns, MicroTiles.Rows, 0, 0); FillLongword(MicroTiles.Tiles^[0], MicroTiles.Count, Value); end; procedure MicroTilesClearUsed(var MicroTiles: TMicroTiles; const Value: TMicroTile); var I: Integer; begin for I := MicroTiles.BoundsUsedTiles.Top to MicroTiles.BoundsUsedTiles.Bottom do FillLongword(MicroTiles.Tiles^[I * MicroTiles.Columns + MicroTiles.BoundsUsedTiles.Left], MicroTiles.BoundsUsedTiles.Right - MicroTiles.BoundsUsedTiles.Left + 1, Value); MicroTiles.BoundsUsedTiles := MakeRect(MicroTiles.Columns, MicroTiles.Rows, 0, 0); end; procedure MicroTilesCopy(var DstTiles: TMicroTiles; SrcTiles: TMicroTiles); var CurRow, Width: Integer; SrcTilePtr, DstTilePtr: PMicroTile; begin if Assigned(DstTiles.Tiles) and (DstTiles.Count > 0) then MicroTilesClearUsed(DstTiles); DstTiles.BoundsRect := SrcTiles.BoundsRect; DstTiles.Columns := SrcTiles.Columns; DstTiles.Rows := SrcTiles.Rows; DstTiles.BoundsUsedTiles := SrcTiles.BoundsUsedTiles; ReallocMem(DstTiles.Tiles, SrcTiles.Count * SizeOf(TMicroTile)); if DstTiles.Count < SrcTiles.Count then FillLongword(DstTiles.Tiles^[DstTiles.Count], SrcTiles.Count - DstTiles.Count, MICROTILE_EMPTY); DstTiles.Count := SrcTiles.Count; SrcTilePtr := @SrcTiles.Tiles^[SrcTiles.BoundsUsedTiles.Top * SrcTiles.Columns + SrcTiles.BoundsUsedTiles.Left]; DstTilePtr := @DstTiles.Tiles^[SrcTiles.BoundsUsedTiles.Top * DstTiles.Columns + SrcTiles.BoundsUsedTiles.Left]; Width := SrcTiles.BoundsUsedTiles.Right - SrcTiles.BoundsUsedTiles.Left + 1; for CurRow := SrcTiles.BoundsUsedTiles.Top to SrcTiles.BoundsUsedTiles.Bottom do begin MoveLongword(SrcTilePtr^, DstTilePtr^, Width); Inc(DstTilePtr, DstTiles.Columns); Inc(SrcTilePtr, SrcTiles.Columns); end end; procedure MicroTilesAddLine(var MicroTiles: TMicroTiles; X1, Y1, X2, Y2: Integer; LineWidth: Integer; RoundToWholeTiles: Boolean = False); var I: Integer; Dx, Dy: Integer; Sx, Sy: Integer; DeltaX, DeltaY: Integer; Rects: Integer; NewX, NewY: Integer; TempRect: TRect; Swapped: Boolean; begin Dx := X2 - X1; Dy := Y2 - Y1; LineWidth := LineWidth shl 1; if Dx > 0 then Sx := 1 else if Dx < 0 then begin Dx := -Dx; Sx := -1; end else // Dx = 0 begin TempRect := MakeRect(X1, Y1, X2, Y2); InflateArea(TempRect, LineWidth, LineWidth); MicroTilesAddRect(MicroTiles, TempRect, RoundToWholeTiles); Exit; end; if Dy > 0 then Sy := 1 else if Dy < 0 then begin Dy := -Dy; Sy := -1; end else // Dy = 0 begin TempRect := MakeRect(X1, Y1, X2, Y2); InflateArea(TempRect, LineWidth, LineWidth); MicroTilesAddRect(MicroTiles, TempRect, RoundToWholeTiles); Exit; end; X1 := X1 * FixedOne; Y1 := Y1 * FixedOne; Dx := Dx * FixedOne; Dy := Dy * FixedOne; if Dx < Dy then begin Swapped := True; Swap(Dx, Dy); end else Swapped := False; Rects := Dx div MICROTILE_SIZE; DeltaX := MICROTILE_SIZE * FixedOne; DeltaY := FixedDiv(Dy, Rects); if Swapped then Swap(DeltaX, DeltaY); DeltaX := Sx * DeltaX; DeltaY := Sy * DeltaY; for I := 1 to FixedCeil(Rects) do begin NewX := X1 + DeltaX; NewY := Y1 + DeltaY; TempRect := MakeRect(FixedRect(X1, Y1, NewX, NewY)); InflateArea(TempRect, LineWidth, LineWidth); MicroTilesAddRect(MicroTiles, TempRect, RoundToWholeTiles); X1 := NewX; Y1 := NewY; end; end; procedure MicroTilesAddRect(var MicroTiles: TMicroTiles; Rect: TRect; RoundToWholeTiles: Boolean); var ModLeft, ModRight, ModTop, ModBottom, Temp: Integer; LeftTile, TopTile, RightTile, BottomTile, ColSpread, RowSpread: Integer; CurRow, CurCol: Integer; TilePtr, TilePtr2: PMicroTile; begin if MicroTiles.Count = 0 then Exit; with Rect do begin TestSwap(Left, Right); TestSwap(Top, Bottom); if Left < 0 then Left := 0; if Top < 0 then Top := 0; Temp := MicroTiles.Columns shl MICROTILE_SHIFT; if Right > Temp then Right := Temp; Temp := MicroTiles.Rows shl MICROTILE_SHIFT; if Bottom > Temp then Bottom := Temp; if (Left > Right) or (Top > Bottom) then Exit; end; LeftTile := Rect.Left shr MICROTILE_SHIFT; TopTile := Rect.Top shr MICROTILE_SHIFT; RightTile := Rect.Right shr MICROTILE_SHIFT; BottomTile := Rect.Bottom shr MICROTILE_SHIFT; TilePtr := @MicroTiles.Tiles^[TopTile * MicroTiles.Columns + LeftTile]; if RoundToWholeTiles then begin for CurRow := TopTile to BottomTile do begin FillLongword(TilePtr^, RightTile - LeftTile + 1, MICROTILE_FULL); Inc(TilePtr, MicroTiles.Columns); end; end else begin // calculate number of tiles needed in columns and rows ColSpread := ((Rect.Right + MICROTILE_SIZE) shr MICROTILE_SHIFT) - (Rect.Left shr MICROTILE_SHIFT); RowSpread := ((Rect.Bottom + MICROTILE_SIZE) shr MICROTILE_SHIFT) - (Rect.Top shr MICROTILE_SHIFT); ModLeft := Rect.Left mod MICROTILE_SIZE; ModTop := Rect.Top mod MICROTILE_SIZE; ModRight := Rect.Right mod MICROTILE_SIZE; ModBottom := Rect.Bottom mod MICROTILE_SIZE; if (ColSpread = 1) and (RowSpread = 1) then MicroTileUnion(TilePtr^, MakeMicroTile(ModLeft, ModTop, ModRight, ModBottom)) else if ColSpread = 1 then begin MicroTileUnion(TilePtr^, MakeMicroTile(ModLeft, ModTop, ModRight, MICROTILE_SIZE)); Inc(TilePtr, MicroTiles.Columns); if RowSpread > 2 then for CurCol := TopTile + 1 to BottomTile - 1 do begin MicroTileUnion(TilePtr^, MakeMicroTile(ModLeft, 0, ModRight, MICROTILE_SIZE)); Inc(TilePtr, MicroTiles.Columns); end; MicroTileUnion(TilePtr^, MakeMicroTile(ModLeft, 0, ModRight, ModBottom)); end else if RowSpread = 1 then begin MicroTileUnion(TilePtr^, MakeMicroTile(ModLeft, ModTop, MICROTILE_SIZE, ModBottom)); Inc(TilePtr); if ColSpread > 2 then for CurRow := LeftTile + 1 to RightTile - 1 do begin MicroTileUnion(TilePtr^, MakeMicroTile(0, ModTop, MICROTILE_SIZE, ModBottom)); Inc(TilePtr); end; MicroTileUnion(TilePtr^, MakeMicroTile(0, ModTop, ModRight, ModBottom)); end else begin TilePtr2 := TilePtr; // TOP: // render top-left corner MicroTileUnion(TilePtr2^, MakeMicroTile(ModLeft, ModTop, MICROTILE_SIZE, MICROTILE_SIZE)); Inc(TilePtr2); // render top edge if ColSpread > 2 then for CurRow := LeftTile + 1 to RightTile - 1 do begin MicroTileUnion(TilePtr2^, MakeMicroTile(0, ModTop, MICROTILE_SIZE, MICROTILE_SIZE)); Inc(TilePtr2); end; // render top-right corner MicroTileUnion(TilePtr2^, MakeMicroTile(0, ModTop, ModRight, MICROTILE_SIZE)); Inc(TilePtr, MicroTiles.Columns); // INTERMEDIATE AREA: if RowSpread > 2 then for CurCol := TopTile + 1 to BottomTile - 1 do begin TilePtr2 := TilePtr; // render left edge MicroTileUnion(TilePtr2^, MakeMicroTile(ModLeft, 0, MICROTILE_SIZE, MICROTILE_SIZE)); Inc(TilePtr2); // render content if ColSpread > 2 then begin FillLongword(TilePtr2^, RightTile - LeftTile - 1, MICROTILE_FULL); Inc(TilePtr2, RightTile - LeftTile - 1); end; // render right edge MicroTileUnion(TilePtr2^, MakeMicroTile(0, 0, ModRight, MICROTILE_SIZE)); Inc(TilePtr, MicroTiles.Columns); end; TilePtr2 := TilePtr; // BOTTOM: // render bottom-left corner MicroTileUnion(TilePtr2^, MakeMicroTile(ModLeft, 0, MICROTILE_SIZE, ModBottom)); Inc(TilePtr2); // render bottom edge if ColSpread > 2 then for CurRow := LeftTile + 1 to RightTile - 1 do begin MicroTileUnion(TilePtr2^, MakeMicroTile(0, 0, MICROTILE_SIZE, ModBottom)); Inc(TilePtr2); end; // render bottom-right corner MicroTileUnion(TilePtr2^, MakeMicroTile(0, 0, ModRight, ModBottom)); end; end; with MicroTiles.BoundsUsedTiles do begin if LeftTile < Left then Left := LeftTile; if TopTile < Top then Top := TopTile; if RightTile > Right then Right := RightTile; if BottomTile > Bottom then Bottom := BottomTile; end; end; procedure MicroTilesUnion_Pas(var DstTiles: TMicroTiles; const SrcTiles: TMicroTiles); var SrcTilePtr, DstTilePtr: PMicroTile; SrcTilePtr2, DstTilePtr2: PMicroTile; X, Y: Integer; SrcLeft, SrcTop, SrcRight, SrcBottom: Integer; SrcTile: TMicroTile; begin SrcTilePtr := @SrcTiles.Tiles^[SrcTiles.BoundsUsedTiles.Top * SrcTiles.Columns + SrcTiles.BoundsUsedTiles.Left]; DstTilePtr := @DstTiles.Tiles^[SrcTiles.BoundsUsedTiles.Top * DstTiles.Columns + SrcTiles.BoundsUsedTiles.Left]; for Y := SrcTiles.BoundsUsedTiles.Top to SrcTiles.BoundsUsedTiles.Bottom do begin SrcTilePtr2 := SrcTilePtr; DstTilePtr2 := DstTilePtr; for X := SrcTiles.BoundsUsedTiles.Left to SrcTiles.BoundsUsedTiles.Right do begin SrcTile := SrcTilePtr2^; SrcLeft := SrcTile shr 24; SrcTop := (SrcTile and $FF0000) shr 16; SrcRight := (SrcTile and $FF00) shr 8; SrcBottom := SrcTile and $FF; if (DstTilePtr2^ <> MICROTILE_FULL) and (SrcTilePtr2^ <> MICROTILE_EMPTY) and (SrcRight - SrcLeft <> 0) and (SrcBottom - SrcTop <> 0) then begin if (DstTilePtr2^ = MICROTILE_EMPTY) or (SrcTilePtr2^ = MICROTILE_FULL) then DstTilePtr2^ := SrcTilePtr2^ else DstTilePtr2^ := Min(DstTilePtr2^ shr 24, SrcLeft) shl 24 or Min(DstTilePtr2^ shr 16 and $FF, SrcTop) shl 16 or Max(DstTilePtr2^ shr 8 and $FF, SrcRight) shl 8 or Max(DstTilePtr2^ and $FF, SrcBottom); end; Inc(DstTilePtr2); Inc(SrcTilePtr2); end; Inc(DstTilePtr, DstTiles.Columns); Inc(SrcTilePtr, SrcTiles.Columns); end; end; {$IFDEF TARGET_x86} procedure MicroTilesUnion_EMMX(var DstTiles: TMicroTiles; const SrcTiles: TMicroTiles); var SrcTilePtr, DstTilePtr: PMicroTile; SrcTilePtr2, DstTilePtr2: PMicroTile; X, Y: Integer; SrcLeft, SrcTop, SrcRight, SrcBottom: Integer; begin SrcTilePtr := @SrcTiles.Tiles^[SrcTiles.BoundsUsedTiles.Top * SrcTiles.Columns + SrcTiles.BoundsUsedTiles.Left]; DstTilePtr := @DstTiles.Tiles^[SrcTiles.BoundsUsedTiles.Top * DstTiles.Columns + SrcTiles.BoundsUsedTiles.Left]; asm MOV ECX, $FFFF // Mask MOVD MM0, ECX MOVQ MM4, MM0 PSLLD MM4, 16 // shift mask left by 16 bits end; for Y := SrcTiles.BoundsUsedTiles.Top to SrcTiles.BoundsUsedTiles.Bottom do begin SrcTilePtr2 := SrcTilePtr; DstTilePtr2 := DstTilePtr; for X := SrcTiles.BoundsUsedTiles.Left to SrcTiles.BoundsUsedTiles.Right do begin SrcLeft := SrcTilePtr2^ shr 24; SrcTop := (SrcTilePtr2^ and $FF0000) shr 16; SrcRight := (SrcTilePtr2^ and $FF00) shr 8; SrcBottom := SrcTilePtr2^ and $FF; if (DstTilePtr2^ <> MICROTILE_FULL) and (SrcTilePtr2^ <> MICROTILE_EMPTY) and (SrcRight - SrcLeft <> 0) and (SrcBottom - SrcTop <> 0) then begin if (DstTilePtr2^ = MICROTILE_EMPTY) or (SrcTilePtr2^ = MICROTILE_FULL) then DstTilePtr2^ := SrcTilePtr2^ else asm MOV EAX, [DstTilePtr2] MOVD MM2, [EAX] MOV ECX, [SrcTilePtr2] MOVD MM1, [ECX] MOVQ MM3, MM1 PMINUB MM1, MM2 PAND MM1, MM4 PMAXUB MM2, MM3 PAND MM2, MM0 POR MM1, MM2 MOVD [EAX], MM1 end; end; Inc(DstTilePtr2); Inc(SrcTilePtr2); end; Inc(DstTilePtr, DstTiles.Columns); Inc(SrcTilePtr, SrcTiles.Columns); end; asm db $0F,$77 /// EMMS end; end; {$ENDIF} procedure MicroTilesUnion(var DstTiles: TMicroTiles; const SrcTiles: TMicroTiles; RoundToWholeTiles: Boolean); var SrcTilePtr, DstTilePtr: PMicroTile; SrcTilePtr2, DstTilePtr2: PMicroTile; X, Y: Integer; SrcLeft, SrcTop, SrcRight, SrcBottom: Integer; begin if SrcTiles.Count = 0 then Exit; if RoundToWholeTiles then begin SrcTilePtr := @SrcTiles.Tiles^[SrcTiles.BoundsUsedTiles.Top * SrcTiles.Columns + SrcTiles.BoundsUsedTiles.Left]; DstTilePtr := @DstTiles.Tiles^[SrcTiles.BoundsUsedTiles.Top * DstTiles.Columns + SrcTiles.BoundsUsedTiles.Left]; for Y := SrcTiles.BoundsUsedTiles.Top to SrcTiles.BoundsUsedTiles.Bottom do begin SrcTilePtr2 := SrcTilePtr; DstTilePtr2 := DstTilePtr; for X := SrcTiles.BoundsUsedTiles.Left to SrcTiles.BoundsUsedTiles.Right do begin SrcLeft := SrcTilePtr2^ shr 24; SrcTop := (SrcTilePtr2^ and $FF0000) shr 16; SrcRight := (SrcTilePtr2^ and $FF00) shr 8; SrcBottom := SrcTilePtr2^ and $FF; if (DstTilePtr2^ <> MICROTILE_FULL) and (SrcTilePtr2^ <> MICROTILE_EMPTY) and (SrcRight - SrcLeft <> 0) and (SrcBottom - SrcTop <> 0) then DstTilePtr2^ := MICROTILE_FULL; Inc(DstTilePtr2); Inc(SrcTilePtr2); end; Inc(DstTilePtr, DstTiles.Columns); Inc(SrcTilePtr, SrcTiles.Columns); end end else MicroTilesU(DstTiles, SrcTiles); with DstTiles.BoundsUsedTiles do begin if SrcTiles.BoundsUsedTiles.Left < Left then Left := SrcTiles.BoundsUsedTiles.Left; if SrcTiles.BoundsUsedTiles.Top < Top then Top := SrcTiles.BoundsUsedTiles.Top; if SrcTiles.BoundsUsedTiles.Right > Right then Right := SrcTiles.BoundsUsedTiles.Right; if SrcTiles.BoundsUsedTiles.Bottom > Bottom then Bottom := SrcTiles.BoundsUsedTiles.Bottom; end; end; function MicroTilesCalcRects(const MicroTiles: TMicroTiles; DstRects: TRectList; CountOnly, RoundToWholeTiles: Boolean): Integer; begin Result := MicroTilesCalcRects(MicroTiles, DstRects, MicroTiles.BoundsRect, CountOnly); end; function MicroTilesCalcRects(const MicroTiles: TMicroTiles; DstRects: TRectList; const Clip: TRect; CountOnly, RoundToWholeTiles: Boolean): Integer; var Rects: Array Of TRect; Rect: PRect; CombLUT: Array Of Integer; StartIndex: Integer; CurTile, TempTile: TMicroTile; Temp: Integer; NewLeft, NewTop, NewRight, NewBottom: Integer; CurCol, CurRow, I, RectsCount: Integer; begin Result := 0; if (MicroTiles.Count = 0) or (MicroTiles.BoundsUsedTiles.Right - MicroTiles.BoundsUsedTiles.Left < 0) or (MicroTiles.BoundsUsedTiles.Bottom - MicroTiles.BoundsUsedTiles.Top < 0) then Exit; SetLength(Rects, MicroTiles.Columns * MicroTiles.Rows); SetLength(CombLUT, MicroTiles.Columns * MicroTiles.Rows); FillLongword(CombLUT[0], Length(CombLUT), Cardinal(-1)); I := 0; RectsCount := 0; if not RoundToWholeTiles then for CurRow := 0 to MicroTiles.Rows - 1 do begin CurCol := 0; while CurCol < MicroTiles.Columns do begin CurTile := MicroTiles.Tiles[I]; if CurTile <> MICROTILE_EMPTY then begin Temp := CurRow shl MICROTILE_SHIFT; NewTop := Constrain(Temp + CurTile shr 16 and $FF, Clip.Top, Clip.Bottom); NewBottom := Constrain(Temp + CurTile and $FF, Clip.Top, Clip.Bottom); NewLeft := Constrain(CurCol shl MICROTILE_SHIFT + CurTile shr 24, Clip.Left, Clip.Right); StartIndex := I; if (CurTile shr 8 and $FF = MICROTILE_SIZE) and (CurCol <> MicroTiles.Columns - 1) then begin while True do begin Inc(CurCol); Inc(I); TempTile := MicroTiles.Tiles[I]; if (CurCol = MicroTiles.Columns) or (TempTile shr 16 and $FF <> CurTile shr 16 and $FF) or (TempTile and $FF <> CurTile and $FF) or (TempTile shr 24 <> 0) then begin Dec(CurCol); Dec(I); Break; end; end; end; NewRight := Constrain(CurCol shl MICROTILE_SHIFT + MicroTiles.Tiles[I] shr 8 and $FF, Clip.Left, Clip.Right); Temp := CombLUT[StartIndex]; Rect := nil; if Temp <> -1 then Rect := @Rects[Temp]; if Assigned(Rect) and (Rect.Left = NewLeft) and (Rect.Right = NewRight) and (Rect.Bottom = NewTop) then begin Rect.Bottom := NewBottom; if CurRow <> MicroTiles.Rows - 1 then CombLUT[StartIndex + MicroTiles.Columns] := Temp; end else with Rects[RectsCount] do begin Left := NewLeft; Top := NewTop; Right := NewRight; Bottom := NewBottom; if CurRow <> MicroTiles.Rows - 1 then CombLUT[StartIndex + MicroTiles.Columns] := RectsCount; Inc(RectsCount); end; end; Inc(I); Inc(CurCol); end; end else for CurRow := 0 to MicroTiles.Rows - 1 do begin CurCol := 0; while CurCol < MicroTiles.Columns do begin CurTile := MicroTiles.Tiles[I]; if CurTile <> MICROTILE_EMPTY then begin Temp := CurRow shl MICROTILE_SHIFT; NewTop := Constrain(Temp, Clip.Top, Clip.Bottom); NewBottom := Constrain(Temp + MICROTILE_SIZE, Clip.Top, Clip.Bottom); NewLeft := Constrain(CurCol shl MICROTILE_SHIFT, Clip.Left, Clip.Right); StartIndex := I; if CurCol <> MicroTiles.Columns - 1 then begin while True do begin Inc(CurCol); Inc(I); TempTile := MicroTiles.Tiles[I]; if (CurCol = MicroTiles.Columns) or (TempTile = MICROTILE_EMPTY) then begin Dec(CurCol); Dec(I); Break; end; end; end; NewRight := Constrain(CurCol shl MICROTILE_SHIFT + MICROTILE_SIZE, Clip.Left, Clip.Right); Temp := CombLUT[StartIndex]; Rect := nil; if Temp <> -1 then Rect := @Rects[Temp]; if Assigned(Rect) and (Rect.Left = NewLeft) and (Rect.Right = NewRight) and (Rect.Bottom = NewTop) then begin Rect.Bottom := NewBottom; if CurRow <> MicroTiles.Rows - 1 then CombLUT[StartIndex + MicroTiles.Columns] := Temp; end else with Rects[RectsCount] do begin Left := NewLeft; Top := NewTop; Right := NewRight; Bottom := NewBottom; if CurRow <> MicroTiles.Rows - 1 then CombLUT[StartIndex + MicroTiles.Columns] := RectsCount; Inc(RectsCount); end; end; Inc(I); Inc(CurCol); end; end; Result := RectsCount; if not CountOnly then for I := 0 to RectsCount - 1 do DstRects.Add(Rects[I]); end; function MicroTilesCountEmptyTiles(const MicroTiles: TMicroTiles): Integer; var CurRow, CurCol: Integer; TilePtr: PMicroTile; begin Result := 0; if MicroTiles.Count > 0 then begin TilePtr := @MicroTiles.Tiles^[0]; for CurRow := 0 to MicroTiles.Rows - 1 do for CurCol := 0 to MicroTiles.Columns - 1 do begin if TilePtr^ = MICROTILE_EMPTY then Inc(Result); Inc(TilePtr); end; end; end; {$IFDEF MICROTILES_DEBUGDRAW} procedure MicroTilesDebugDraw(const MicroTiles: TMicroTiles; DstBitmap: TBitmap32; DrawOptimized, RoundToWholeTiles: Boolean); var I: Integer; TempRect: TRect; Rects: TRectList; C1, C2: TColor32; begin {$IFDEF MICROTILES_DEBUGDRAW_RANDOM_COLORS} C1 := Random(MaxInt) AND $00FFFFFF; C2 := C1 OR $90000000; C1 := C1 OR $30000000; {$ELSE} C1 := clDebugDrawFill; C2 := clDebugDrawFrame; {$ENDIF} if DrawOptimized then begin Rects := TRectList.Create; MicroTilesCalcRects(MicroTiles, Rects, False, RoundToWholeTiles); try if Rects.Count > 0 then begin for I := 0 to Rects.Count - 1 do begin DstBitmap.FillRectTS(Rects[I]^, C1); DstBitmap.FrameRectTS(Rects[I]^, C2); end; end finally Rects.Free; end; end else for I := 0 to MicroTiles.Count - 1 do begin if MicroTiles.Tiles^[i] <> MICROTILE_EMPTY then begin TempRect.Left := ((I mod MicroTiles.Columns) shl MICROTILE_SHIFT) + (MicroTiles.Tiles[i] shr 24); TempRect.Top := ((I div MicroTiles.Columns) shl MICROTILE_SHIFT) + (MicroTiles.Tiles[i] shr 16 and $FF); TempRect.Right := ((I mod MicroTiles.Columns) shl MICROTILE_SHIFT) + (MicroTiles.Tiles[i] shr 8 and $FF); TempRect.Bottom := ((I div MicroTiles.Columns) shl MICROTILE_SHIFT) + (MicroTiles.Tiles[i] and $FF); DstBitmap.FillRectTS(TempRect, C1); DstBitmap.FrameRectTS(TempRect, C2); end; end; end; {$ENDIF} { TMicroTilesMap } function TMicroTilesMap.Add(Item: Pointer): PPMicroTiles; var TilesPtr: PMicroTiles; IsNew: Boolean; begin Result := PPMicroTiles(inherited Add(Item, IsNew)); if IsNew then begin New(TilesPtr); MicroTilesCreate(TilesPtr^); Result^ := TilesPtr; end; end; function TMicroTilesMap.Delete(BucketIndex, ItemIndex: Integer): Pointer; var TilesPtr: PMicroTiles; begin TilesPtr := inherited Delete(BucketIndex, ItemIndex); MicroTilesDestroy(TilesPtr^); Dispose(TilesPtr); Result := nil; end; procedure TMicroTilesMap.SetData(Item: Pointer; const Data: PMicroTiles); begin inherited SetData(Item, Data); end; function TMicroTilesMap.GetData(Item: Pointer): PMicroTiles; begin Result := inherited GetData(Item); end; { TMicroTilesRepaintManager } type TLayerCollectionAccess = class(TLayerCollection); TCustomLayerAccess = class(TCustomLayer); const PL_MICROTILES = 0; PL_WHOLETILES = 1; PL_FULLSCENE = 2; TIMER_PENALTY = 250; TIMER_LOWLIMIT = 1000; TIMER_HIGHLIMIT = 5000; INVALIDRECTS_DELTA = 10; constructor TMicroTilesRepaintOptimizer.Create(Buffer: TBitmap32; InvalidRects: TRectList); begin inherited; FOldInvalidTilesMap := TMicroTilesMap.Create; FInvalidLayers := TList.Create; FPerfTimer := TPerfTimer.Create; {$IFNDEF MICROTILES_DEBUGDRAW} {$IFNDEF MICROTILES_NO_ADAPTION} FAdaptiveMode := True; {$ENDIF} {$ENDIF} MicroTilesCreate(FInvalidTiles); MicroTilesCreate(FTempTiles); MicroTilesCreate(FForcedInvalidTiles); {$IFDEF MICROTILES_DEBUGDRAW} MicroTilesCreate(FDebugMicroTiles); FDebugInvalidRects := TRectList.Create; {$ENDIF} end; destructor TMicroTilesRepaintOptimizer.Destroy; begin MicroTilesDestroy(FForcedInvalidTiles); MicroTilesDestroy(FTempTiles); MicroTilesDestroy(FInvalidTiles); FPerfTimer.Free; FInvalidLayers.Free; FOldInvalidTilesMap.Free; {$IFDEF MICROTILES_DEBUGDRAW} FDebugInvalidRects.Free; MicroTilesDestroy(FDebugMicroTiles); {$ENDIF} inherited; end; procedure TMicroTilesRepaintOptimizer.AreaUpdateHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); begin ValidateWorkingTiles; AddArea(FForcedInvalidTiles, Area, Info); FUseInvalidTiles := True; end; procedure TMicroTilesRepaintOptimizer.AddArea(var Tiles: TMicroTiles; const Area: TRect; const Info: Cardinal); var LineWidth: Integer; TempRect: TRect; begin if Info and AREAINFO_LINE <> 0 then begin LineWidth := Info and $00FFFFFF; TempRect := Area; InflateArea(TempRect, LineWidth, LineWidth); with TempRect do MicroTilesAddLine(Tiles, Left, Top, Right, Bottom, LineWidth, FPerformanceLevel > PL_MICROTILES); end else MicroTilesAddRect(Tiles, Area, FPerformanceLevel > PL_MICROTILES); end; procedure TMicroTilesRepaintOptimizer.LayerUpdateHandler(Sender: TObject; Layer: TCustomLayer); begin if FOldInvalidTilesValid and not TCustomLayerAccess(Layer).Invalid then begin FInvalidLayers.Add(Layer); TCustomLayerAccess(Layer).Invalid := True; FUseInvalidTiles := True; end; end; procedure TMicroTilesRepaintOptimizer.LayerCollectionNotifyHandler(Sender: TLayerCollection; Action: TLayerListNotification; Layer: TCustomLayer; Index: Integer); var TilesPtr: PMicroTiles; begin case Action of lnLayerAdded, lnLayerInserted: begin TilesPtr := FOldInvalidTilesMap.Add(Layer)^; MicroTilesSetSize(TilesPtr^, Buffer.BoundsRect); FOldInvalidTilesValid := True; end; lnLayerDeleted: begin if FOldInvalidTilesValid then begin // force repaint of tiles that the layer did previously allocate MicroTilesUnion(FInvalidTiles, FOldInvalidTilesMap[Layer]^); FUseInvalidTiles := True; end; FInvalidLayers.Remove(Layer); FOldInvalidTilesMap.Remove(Layer); end; lnCleared: begin if FOldInvalidTilesValid then begin with TPointerMapIterator.Create(FOldInvalidTilesMap) do try while Next do MicroTilesUnion(FInvalidTiles, PMicroTiles(Data)^); finally Free; end; FUseInvalidTiles := True; ResetAdaptiveMode; end; FOldInvalidTilesMap.Clear; FOldInvalidTilesValid := True; end; end; end; procedure TMicroTilesRepaintOptimizer.ValidateWorkingTiles; begin if not FWorkingTilesValid then // check if working microtiles need resize... begin MicroTilesSetSize(FTempTiles, FBufferBounds); MicroTilesSetSize(FInvalidTiles, FBufferBounds); MicroTilesSetSize(FForcedInvalidTiles, FBufferBounds); FWorkingTilesValid := True; end; end; procedure TMicroTilesRepaintOptimizer.BufferResizedHandler(const NewWidth, NewHeight: Integer); begin FBufferBounds := MakeRect(0, 0, NewWidth, NewHeight); Reset; end; procedure TMicroTilesRepaintOptimizer.Reset; begin FWorkingTilesValid := False; // force resizing of working microtiles FOldInvalidTilesValid := False; // force resizing and rerendering of invalid tiles UpdateOldInvalidTiles; // mark whole buffer area invalid... MicroTilesClear(FForcedInvalidTiles, MICROTILE_FULL); FForcedInvalidTiles.BoundsUsedTiles := MakeRect(0, 0, FForcedInvalidTiles.Columns, FForcedInvalidTiles.Rows); FUseInvalidTiles := True; end; function TMicroTilesRepaintOptimizer.UpdatesAvailable: Boolean; begin UpdateOldInvalidTiles; Result := FUseInvalidTiles; end; procedure TMicroTilesRepaintOptimizer.UpdateOldInvalidTiles; var I, J: Integer; TilesPtr: PMicroTiles; Layer: TCustomLayer; begin if not FOldInvalidTilesValid then // check if old Invalid tiles need resize and rerendering... begin ValidateWorkingTiles; for I := 0 to LayerCollections.Count - 1 do with TLayerCollection(LayerCollections[I]) do for J := 0 to Count - 1 do begin Layer := Items[J]; TilesPtr := FOldInvalidTilesMap.Add(Layer)^; MicroTilesSetSize(TilesPtr^, FBufferBounds); DrawLayerToMicroTiles(TilesPtr^, Layer); TCustomLayerAccess(Layer).Invalid := False; end; FInvalidLayers.Clear; FOldInvalidTilesValid := True; FUseInvalidTiles := False; end; end; procedure TMicroTilesRepaintOptimizer.RegisterLayerCollection(Layers: TLayerCollection); begin inherited; if Enabled then with TLayerCollectionAccess(Layers) do begin OnLayerUpdated := LayerUpdateHandler; OnAreaUpdated := AreaUpdateHandler; OnListNotify := LayerCollectionNotifyHandler; end; end; procedure TMicroTilesRepaintOptimizer.UnregisterLayerCollection(Layers: TLayerCollection); begin with TLayerCollectionAccess(Layers) do begin OnLayerUpdated := nil; OnAreaUpdated := nil; OnListNotify := nil; end; inherited; end; procedure TMicroTilesRepaintOptimizer.SetEnabled(const Value: Boolean); var I: Integer; begin if Value <> Enabled then begin if Value then begin // initialize: for I := 0 to LayerCollections.Count - 1 do with TLayerCollectionAccess(LayerCollections[I]) do begin OnLayerUpdated := LayerUpdateHandler; OnAreaUpdated := AreaUpdateHandler; OnListNotify := LayerCollectionNotifyHandler; end; BufferResizedHandler(Buffer.Width, Buffer.Height); end else begin // clean up: for I := 0 to LayerCollections.Count - 1 do with TLayerCollectionAccess(LayerCollections[I]) do begin OnLayerUpdated := nil; OnAreaUpdated := nil; OnListNotify := nil; end; MicroTilesDestroy(FInvalidTiles); MicroTilesDestroy(FTempTiles); MicroTilesDestroy(FForcedInvalidTiles); FUseInvalidTiles := False; FOldInvalidTilesValid := False; FOldInvalidTilesMap.Clear; FInvalidLayers.Clear; end; inherited; end; end; procedure TMicroTilesRepaintOptimizer.SetAdaptiveMode(const Value: Boolean); begin if FAdaptiveMode <> Value then begin FAdaptiveMode := Value; ResetAdaptiveMode; end; end; procedure TMicroTilesRepaintOptimizer.ResetAdaptiveMode; begin FTimeDelta := TIMER_LOWLIMIT; FAdaptionFailed := False; FPerformanceLevel := PL_MICROTILES; end; procedure TMicroTilesRepaintOptimizer.BeginPaintBuffer; begin if AdaptiveMode then FPerfTimer.Start; end; procedure TMicroTilesRepaintOptimizer.EndPaintBuffer; begin FUseInvalidTiles := False; {$IFDEF MICROTILES_DEBUGDRAW} {$IFDEF MICROTILES_DEBUGDRAW_UNOPTIMIZED} MicroTilesDebugDraw(FDebugMicroTiles, Buffer, False, FDebugWholeTiles); {$ELSE} MicroTilesDebugDraw(FDebugMicroTiles, Buffer, True, FDebugWholeTiles); {$ENDIF} MicroTilesClear(FDebugMicroTiles); {$ENDIF} {$IFNDEF MICROTILES_NO_ADAPTION} EndAdaption; {$ENDIF} end; procedure TMicroTilesRepaintOptimizer.DrawLayerToMicroTiles(var DstTiles: TMicroTiles; Layer: TCustomLayer); begin Buffer.BeginMeasuring(DrawMeasuringHandler); FWorkMicroTiles := @DstTiles; TCustomLayerAccess(Layer).DoPaint(Buffer); Buffer.EndMeasuring; end; procedure TMicroTilesRepaintOptimizer.DrawMeasuringHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); begin AddArea(FWorkMicroTiles^, Area, Info); end; procedure TMicroTilesRepaintOptimizer.PerformOptimization; var I: Integer; Layer: TCustomLayer; UseWholeTiles: Boolean; LayerTilesPtr: PMicroTiles; begin if FUseInvalidTiles then begin ValidateWorkingTiles; // Determine if the use of whole tiles is better for current performance level {$IFNDEF MICROTILES_NO_ADAPTION} UseWholeTiles := FPerformanceLevel > PL_MICROTILES; {$ELSE} {$IFDEF MICROTILES_NO_ADAPTION_FORCE_WHOLETILES} UseWholeTiles := True; {$ELSE} UseWholeTiles := False; {$ENDIF} {$ENDIF} if FInvalidLayers.Count > 0 then begin for I := 0 to FInvalidLayers.Count - 1 do begin Layer := FInvalidLayers[I]; // Clear temporary tiles MicroTilesClearUsed(FTempTiles); // Draw layer to temporary tiles DrawLayerToMicroTiles(FTempTiles, Layer); // Combine temporary tiles with the global invalid tiles MicroTilesUnion(FInvalidTiles, FTempTiles, UseWholeTiles); // Retrieve old invalid tiles for the current layer LayerTilesPtr := FOldInvalidTilesMap[Layer]; // Combine old invalid tiles with the global invalid tiles MicroTilesUnion(FInvalidTiles, LayerTilesPtr^, UseWholeTiles); // Copy temporary (current) invalid tiles to the layer MicroTilesCopy(LayerTilesPtr^, FTempTiles); // Unmark layer as invalid TCustomLayerAccess(Layer).Invalid := False; end; FInvalidLayers.Clear; end; {$IFDEF MICROTILES_DEBUGDRAW} MicroTilesCalcRects(FInvalidTiles, InvalidRects, False, UseWholeTiles); MicroTilesCalcRects(FForcedInvalidTiles, InvalidRects, False, UseWholeTiles); MicroTilesCopy(FDebugMicroTiles, FInvalidTiles); MicroTilesUnion(FDebugMicroTiles, FForcedInvalidTiles); FDebugWholeTiles := UseWholeTiles; {$ELSE} // Calculate optimized rectangles from global invalid tiles MicroTilesCalcRects(FInvalidTiles, InvalidRects, False, UseWholeTiles); // Calculate optimized rectangles from forced invalid tiles MicroTilesCalcRects(FForcedInvalidTiles, InvalidRects, False, UseWholeTiles); {$ENDIF} end; {$IFNDEF MICROTILES_NO_ADAPTION} BeginAdaption; {$ENDIF} {$IFDEF MICROTILES_DEBUGDRAW} if InvalidRects.Count > 0 then begin FDebugInvalidRects.Count := InvalidRects.Count; Move(InvalidRects[0]^, FDebugInvalidRects[0]^, InvalidRects.Count * SizeOf(TRect)); InvalidRects.Clear; end; {$ENDIF} // Rects have been created, so we don't need the tiles any longer, clear them. MicroTilesClearUsed(FInvalidTiles); MicroTilesClearUsed(FForcedInvalidTiles); end; procedure TMicroTilesRepaintOptimizer.BeginAdaption; begin if AdaptiveMode and (FPerformanceLevel > PL_MICROTILES) then begin if Integer(GetTickCount) > FNextCheck then begin FPerformanceLevel := Constrain(FPerformanceLevel - 1, PL_MICROTILES, PL_FULLSCENE); {$IFDEF CODESITE} CodeSite.SendInteger('PrepareInvalidRects(Timed): FPerformanceLevel', FPerformanceLevel); {$ENDIF} FTimedCheck := True; end else if not FAdaptionFailed and (InvalidRects.Count < FOldInvalidRectsCount - INVALIDRECTS_DELTA) then begin FPerformanceLevel := Constrain(FPerformanceLevel - 1, PL_MICROTILES, PL_FULLSCENE); {$IFDEF CODESITE} CodeSite.SendInteger('PrepareInvalidRects: FPerformanceLevel', FPerformanceLevel); {$ENDIF} end else if FPerformanceLevel = PL_FULLSCENE then // we need a full scene rendition, so clear the invalid rects InvalidRects.Clear; end; end; procedure TMicroTilesRepaintOptimizer.EndAdaption; var TimeElapsed: Int64; Level: Integer; begin // our KISS(TM) repaint mode balancing starts here... TimeElapsed := FPerfTimer.ReadValue; {$IFDEF MICROTILES_DEBUGDRAW} if FDebugInvalidRects.Count = 0 then {$ELSE} if InvalidRects.Count = 0 then {$ENDIF} FElapsedTimeForFullSceneRepaint := TimeElapsed else if AdaptiveMode then begin if TimeElapsed > FElapsedTimeForFullSceneRepaint then begin Level := Constrain(FPerformanceLevel + 1, PL_MICROTILES, PL_FULLSCENE); // did performance level change from previous level? if Level <> FPerformanceLevel then begin {$IFDEF MICROTILES_DEBUGDRAW} FOldInvalidRectsCount := FDebugInvalidRects.Count; {$ELSE} // save count of old invalid rects so we can use it in PrepareInvalidRects // the next time... FOldInvalidRectsCount := InvalidRects.Count; {$ENDIF} FPerformanceLevel := Level; {$IFDEF CODESITE} CodeSite.SendInteger('EndPaintBuffer: FPerformanceLevel', FPerformanceLevel); {$ENDIF} // was this a timed check? if FTimedCheck then begin // time based approach failed, so add penalty FTimeDelta := Constrain(Integer(FTimeDelta + TIMER_PENALTY), TIMER_LOWLIMIT, TIMER_HIGHLIMIT); // schedule next check FNextCheck := Integer(GetTickCount) + FTimeDelta; FElapsedTimeOnLastPenalty := TimeElapsed; FTimedCheck := False; {$IFDEF CODESITE} CodeSite.SendInteger('timed check failed, new delta', FTimeDelta); {$ENDIF} end; {$IFDEF CODESITE} CodeSite.AddSeparator; {$ENDIF} FAdaptionFailed := True; end; end else if TimeElapsed < FElapsedTimeForFullSceneRepaint then begin if FTimedCheck then begin // time based approach had success!! // reset time delta back to lower limit, ie. remove penalties FTimeDelta := TIMER_LOWLIMIT; // schedule next check FNextCheck := Integer(GetTickCount) + FTimeDelta; FTimedCheck := False; {$IFDEF CODESITE} CodeSite.SendInteger('timed check succeeded, new delta', FTimeDelta); CodeSite.AddSeparator; {$ENDIF} FAdaptionFailed := False; end else begin // invalid rect count approach had success!! // shorten time for next check to benefit nonetheless in case we have a fallback... if FTimeDelta > TIMER_LOWLIMIT then begin // remove the penalty value 4 times from the current time delta FTimeDelta := Constrain(FTimeDelta - 4 * TIMER_PENALTY, TIMER_LOWLIMIT, TIMER_HIGHLIMIT); // schedule next check FNextCheck := Integer(GetTickCount) + FTimeDelta; {$IFDEF CODESITE} CodeSite.SendInteger('invalid rect count approach succeeded, new timer delta', FTimeDelta); CodeSite.AddSeparator; {$ENDIF} end; FAdaptionFailed := False; end; end else if (TimeElapsed < FElapsedTimeOnLastPenalty) and FTimedCheck then begin // time approach had success optimizing the situation, so shorten time until next check FTimeDelta := Constrain(FTimeDelta - TIMER_PENALTY, TIMER_LOWLIMIT, TIMER_HIGHLIMIT); // schedule next check FNextCheck := Integer(GetTickCount) + FTimeDelta; FTimedCheck := False; {$IFDEF CODESITE} CodeSite.SendInteger('timed check succeeded, new delta', FTimeDelta); CodeSite.AddSeparator; {$ENDIF} end; end; FElapsedTimeForLastRepaint := TimeElapsed; end; {$IFDEF CODESITE} { TDebugMicroTilesRepaintOptimizer } procedure TDebugMicroTilesRepaintOptimizer.AreaUpdateHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); begin DumpCallStack('TDebugMicroTilesRepaintOptimizer.AreaUpdateHandler'); inherited; end; procedure TDebugMicroTilesRepaintOptimizer.BeginPaintBuffer; begin DumpCallStack('TDebugMicroTilesRepaintOptimizer.BeginPaintBuffer'); inherited; end; procedure TDebugMicroTilesRepaintOptimizer.BufferResizedHandler(const NewWidth, NewHeight: Integer); begin DumpCallStack('TDebugMicroTilesRepaintOptimizer.BufferResizedHandler'); inherited; end; procedure TDebugMicroTilesRepaintOptimizer.EndPaintBuffer; begin DumpCallStack('TDebugMicroTilesRepaintOptimizer.EndPaintBuffer'); inherited; CodeSite.AddSeparator; end; procedure TDebugMicroTilesRepaintOptimizer.LayerUpdateHandler(Sender: TObject; Layer: TCustomLayer); begin DumpCallStack('TDebugMicroTilesRepaintOptimizer.LayerUpdateHandler'); inherited; end; procedure TDebugMicroTilesRepaintOptimizer.PerformOptimization; begin DumpCallStack('TDebugMicroTilesRepaintOptimizer.PerformOptimization'); inherited; end; procedure TDebugMicroTilesRepaintOptimizer.Reset; begin DumpCallStack('TDebugMicroTilesRepaintOptimizer.Reset'); inherited; CodeSite.AddSeparator; end; function TDebugMicroTilesRepaintOptimizer.UpdatesAvailable: Boolean; begin DumpCallStack('TDebugMicroTilesRepaintOptimizer.UpdatesAvailable'); Result := inherited UpdatesAvailable; end; {$ENDIF} const FID_MICROTILEUNION = 0; FID_MICROTILESUNION = 1; var Registry: TFunctionRegistry; procedure RegisterBindings; begin Registry := NewRegistry('GR32_MicroTiles bindings'); Registry.RegisterBinding(FID_MICROTILEUNION, @@MicroTileUnion); Registry.RegisterBinding(FID_MICROTILESUNION, @@MicroTilesU); Registry.Add(FID_MICROTILEUNION, @MicroTileUnion_Pas); Registry.Add(FID_MICROTILESUNION, @MicroTilesUnion_Pas); {$IFNDEF PUREPASCAL} {$IFDEF TARGET_x86} Registry.Add(FID_MICROTILEUNION, @MicroTileUnion_EMMX, [ciEMMX]); Registry.Add(FID_MICROTILESUNION, @MicroTilesUnion_EMMX, [ciEMMX]); {$ENDIF} {$ENDIF} Registry.RebindAll; end; initialization RegisterBindings; end. |
Added src/graphics32/GR32_OrdinalMaps.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 | unit GR32_OrdinalMaps; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson * (parts of this unit were merged from GR32_ByteMaps.pas by Alex A. Denisov) * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Michael Hansen * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} Controls, Graphics, {$IFDEF Windows} Windows, {$ENDIF} {$ELSE} Windows, Controls, Graphics, {$ENDIF} Classes, SysUtils, GR32; type TConversionType = (ctRed, ctGreen, ctBlue, ctAlpha, ctUniformRGB, ctWeightedRGB); TBooleanMap = class(TCustomMap) private function GetValue(X, Y: Integer): Boolean; procedure SetValue(X, Y: Integer; const Value: Boolean); protected FBits: PByteArray; procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; public constructor Create; overload; override; destructor Destroy; override; function Empty: Boolean; override; procedure Clear(FillValue: Byte); procedure ToggleBit(X, Y: Integer); property Value[X, Y: Integer]: Boolean read GetValue write SetValue; default; property Bits: PByteArray read FBits; end; TByteMap = class(TCustomMap) private function GetValue(X, Y: Integer): Byte; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function GetValPtr(X, Y: Integer): PByte; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} procedure SetValue(X, Y: Integer; Value: Byte); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function GetScanline(Y: Integer): PByteArray; protected FBits: PByteArray; procedure AssignTo(Dst: TPersistent); override; procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; public constructor Create; overload; override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; function Empty: Boolean; override; procedure Clear(FillValue: Byte); procedure ReadFrom(Source: TCustomBitmap32; Conversion: TConversionType); procedure WriteTo(Dest: TCustomBitmap32; Conversion: TConversionType); overload; procedure WriteTo(Dest: TCustomBitmap32; const Palette: TPalette32); overload; property Bits: PByteArray read FBits; property Scanline[Y: Integer]: PByteArray read GetScanline; property ValPtr[X, Y: Integer]: PByte read GetValPtr; property Value[X, Y: Integer]: Byte read GetValue write SetValue; default; end; { TWordMap } TWordMap = class(TCustomMap) private function GetValPtr(X, Y: Integer): PWord; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function GetValue(X, Y: Integer): Word; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} procedure SetValue(X, Y: Integer; const Value: Word); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function GetScanline(Y: Integer): PWordArray; protected FBits: PWordArray; procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; public constructor Create; overload; override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; function Empty: Boolean; override; procedure Clear(FillValue: Word); property ValPtr[X, Y: Integer]: PWord read GetValPtr; property Value[X, Y: Integer]: Word read GetValue write SetValue; default; property Bits: PWordArray read FBits; property Scanline[Y: Integer]: PWordArray read GetScanline; end; { TIntegerMap } TIntegerMap = class(TCustomMap) private function GetValPtr(X, Y: Integer): PInteger; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function GetValue(X, Y: Integer): Integer; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} procedure SetValue(X, Y: Integer; const Value: Integer); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function GetScanline(Y: Integer): PIntegerArray; protected FBits: PIntegerArray; procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; public constructor Create; overload; override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; function Empty: Boolean; override; procedure Clear(FillValue: Integer = 0); property ValPtr[X, Y: Integer]: PInteger read GetValPtr; property Value[X, Y: Integer]: Integer read GetValue write SetValue; default; property Bits: PIntegerArray read FBits; property Scanline[Y: Integer]: PIntegerArray read GetScanline; end; { TCardinalMap } TCardinalMap = class(TCustomMap) private function GetValPtr(X, Y: Cardinal): PCardinal; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function GetValue(X, Y: Cardinal): Cardinal; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} procedure SetValue(X, Y: Cardinal; const Value: Cardinal); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function GetScanline(Y: Integer): PCardinalArray; protected FBits: PCardinalArray; procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; public constructor Create; overload; override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; function Empty: Boolean; override; procedure Clear(FillValue: Cardinal = 0); property ValPtr[X, Y: Cardinal]: PCardinal read GetValPtr; property Value[X, Y: Cardinal]: Cardinal read GetValue write SetValue; default; property Bits: PCardinalArray read FBits; property Scanline[Y: Integer]: PCardinalArray read GetScanline; end; { TFloatMap } TFloatMap = class(TCustomMap) private function GetValPtr(X, Y: Integer): PFloat; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function GetValue(X, Y: Integer): TFloat; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} procedure SetValue(X, Y: Integer; const Value: TFloat); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} function GetScanline(Y: Integer): PFloatArray; protected FBits: PFloatArray; procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; public constructor Create; overload; override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; function Empty: Boolean; override; procedure Clear; overload; procedure Clear(FillValue: TFloat); overload; property ValPtr[X, Y: Integer]: PFloat read GetValPtr; property Value[X, Y: Integer]: TFloat read GetValue write SetValue; default; property Bits: PFloatArray read FBits; property Scanline[Y: Integer]: PFloatArray read GetScanline; end; {$IFDEF COMPILER2010} { TGenericMap<T> } TGenericMap<T> = class(TCustomMap) private function GetValue(X, Y: Integer): T; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} procedure SetValue(X, Y: Integer; const Value: T); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} protected FBits: Pointer; procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; public constructor Create; overload; override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; function Empty: Boolean; override; procedure Clear; overload; procedure Clear(FillValue: T); overload; property Value[X, Y: Integer]: T read GetValue write SetValue; default; property Bits: Pointer read FBits; end; {$ENDIF} implementation uses GR32_LowLevel; function Bytes(Bits: Integer): Integer; begin Result := (Bits - 1) shr 3 + 1; end; { TBooleanMap } constructor TBooleanMap.Create; begin FreeMem(FBits); inherited Create; end; procedure TBooleanMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); begin ReallocMem(FBits, Bytes(NewWidth * NewHeight)); Width := NewWidth; Height := NewHeight; end; procedure TBooleanMap.Clear(FillValue: Byte); begin FillChar(FBits^, Bytes(Width * Height), FillValue); end; destructor TBooleanMap.Destroy; begin FBits := nil; inherited; end; function TBooleanMap.Empty: Boolean; begin Result := not Assigned(FBits); end; function TBooleanMap.GetValue(X, Y: Integer): Boolean; begin X := X + Y * Width; Result := FBits^[X shr 3] and (1 shl (X and 7)) <> 0; //Boolean(FBits^[X shr 3] and (1 shl (X and 7))); end; procedure TBooleanMap.SetValue(X, Y: Integer; const Value: Boolean); begin X := Y * Width + X; if Value then FBits^[X shr 3] := FBits^[X shr 3] or (1 shl (X and 7)) else FBits^[X shr 3] := FBits^[X shr 3] and ((1 shl (X and 7)) xor $FF); end; procedure TBooleanMap.ToggleBit(X, Y: Integer); begin X := Y * Width + X; FBits^[X shr 3] := FBits^[X shr 3] xor (1 shl (X and 7)); end; { TByteMap } constructor TByteMap.Create; begin FBits := nil; inherited Create; end; destructor TByteMap.Destroy; begin FreeMem(FBits); inherited; end; procedure TByteMap.Assign(Source: TPersistent); begin BeginUpdate; try if Source is TByteMap then begin inherited SetSize(TByteMap(Source).Width, TByteMap(Source).Height); Move(TByteMap(Source).Bits[0], Bits[0], Width * Height); end else if Source is TBitmap32 then ReadFrom(TBitmap32(Source), ctWeightedRGB) else inherited; finally EndUpdate; Changed; end; end; procedure TByteMap.AssignTo(Dst: TPersistent); begin if Dst is TBitmap32 then WriteTo(TBitmap32(Dst), ctUniformRGB) else inherited; end; procedure TByteMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); begin ReallocMem(FBits, NewWidth * NewHeight); Width := NewWidth; Height := NewHeight; end; procedure TByteMap.Clear(FillValue: Byte); begin FillChar(Bits^, Width * Height, FillValue); Changed; end; function TByteMap.Empty: Boolean; begin Result := False; if (Width = 0) or (Height = 0) or (FBits = nil) then Result := True; end; function TByteMap.GetScanline(Y: Integer): PByteArray; begin Result := @FBits^[Y * Width]; end; function TByteMap.GetValPtr(X, Y: Integer): PByte; begin Result := @FBits^[X + Y * Width]; end; function TByteMap.GetValue(X, Y: Integer): Byte; begin Result := FBits^[X + Y * Width]; end; procedure TByteMap.ReadFrom(Source: TCustomBitmap32; Conversion: TConversionType); var W, H, I, N: Integer; SrcC: PColor32; SrcB, DstB: PByte; Value: TColor32; begin BeginUpdate; try SetSize(Source.Width, Source.Height); if Empty then Exit; W := Source.Width; H := Source.Height; N := W * H - 1; SrcC := Source.PixelPtr[0, 0]; SrcB := Pointer(SrcC); DstB := @FBits^; case Conversion of ctRed: begin Inc(SrcB, 2); for I := 0 to N do begin DstB^ := SrcB^; Inc(DstB); Inc(SrcB, 4); end; end; ctGreen: begin Inc(SrcB, 1); for I := 0 to N do begin DstB^ := SrcB^; Inc(DstB); Inc(SrcB, 4); end; end; ctBlue: begin for I := 0 to N do begin DstB^ := SrcB^; Inc(DstB); Inc(SrcB, 4); end; end; ctAlpha: begin Inc(SrcB, 3); for I := 0 to N do begin DstB^ := SrcB^; Inc(DstB); Inc(SrcB, 4); end; end; ctUniformRGB: begin for I := 0 to N do begin Value := SrcC^; Value := (Value and $00FF0000) shr 16 + (Value and $0000FF00) shr 8 + (Value and $000000FF); Value := Value div 3; DstB^ := Value; Inc(DstB); Inc(SrcC); end; end; ctWeightedRGB: begin for I := 0 to N do begin DstB^ := Intensity(SrcC^); Inc(DstB); Inc(SrcC); end; end; end; finally EndUpdate; Changed; end; end; procedure TByteMap.SetValue(X, Y: Integer; Value: Byte); begin FBits^[X + Y * Width] := Value; end; procedure TByteMap.WriteTo(Dest: TCustomBitmap32; Conversion: TConversionType); var W, H, I, N: Integer; DstC: PColor32; DstB, SrcB: PByte; Resized: Boolean; begin Dest.BeginUpdate; Resized := False; try Resized := Dest.SetSize(Width, Height); if Empty then Exit; W := Width; H := Height; N := W * H - 1; DstC := Dest.PixelPtr[0, 0]; DstB := Pointer(DstC); SrcB := @FBits^; case Conversion of ctRed: begin Inc(DstB, 2); for I := 0 to N do begin DstB^ := SrcB^; Inc(DstB, 4); Inc(SrcB); end; end; ctGreen: begin Inc(DstB, 1); for I := 0 to N do begin DstB^ := SrcB^; Inc(DstB, 4); Inc(SrcB); end; end; ctBlue: begin for I := 0 to N do begin DstB^ := SrcB^; Inc(DstB, 4); Inc(SrcB); end; end; ctAlpha: begin Inc(DstB, 3); for I := 0 to N do begin DstB^ := SrcB^; Inc(DstB, 4); Inc(SrcB); end; end; ctUniformRGB, ctWeightedRGB: begin for I := 0 to N do begin DstC^ := Gray32(SrcB^); Inc(DstC); Inc(SrcB); end; end; end; finally Dest.EndUpdate; Dest.Changed; if Resized then Dest.Resized; end; end; procedure TByteMap.WriteTo(Dest: TCustomBitmap32; const Palette: TPalette32); var W, H, I, N: Integer; DstC: PColor32; SrcB: PByte; begin Dest.BeginUpdate; try Dest.SetSize(Width, Height); if Empty then Exit; W := Width; H := Height; N := W * H - 1; DstC := Dest.PixelPtr[0, 0]; SrcB := @FBits^; for I := 0 to N do begin DstC^ := Palette[SrcB^]; Inc(DstC); Inc(SrcB); end; finally Dest.EndUpdate; Dest.Changed; end; end; { TWordMap } constructor TWordMap.Create; begin FBits := nil; inherited Create; end; destructor TWordMap.Destroy; begin FreeMem(FBits); inherited; end; procedure TWordMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); begin ReallocMem(FBits, NewWidth * NewHeight * SizeOf(Word)); Width := NewWidth; Height := NewHeight; end; procedure TWordMap.Clear(FillValue: Word); begin FillWord(FBits^, Width * Height, FillValue); Changed; end; procedure TWordMap.Assign(Source: TPersistent); begin BeginUpdate; try if Source is TWordMap then begin inherited SetSize(TWordMap(Source).Width, TWordMap(Source).Height); Move(TWordMap(Source).Bits[0], Bits[0], Width * Height * SizeOf(Word)); end //else if Source is TBitmap32 then // ReadFrom(TBitmap32(Source), ctWeightedRGB) else inherited; finally EndUpdate; Changed; end; end; function TWordMap.Empty: Boolean; begin Result := not Assigned(FBits); end; function TWordMap.GetScanline(Y: Integer): PWordArray; begin Result := @FBits^[Y * Width]; end; function TWordMap.GetValPtr(X, Y: Integer): PWord; begin Result := @FBits^[X + Y * Width]; end; function TWordMap.GetValue(X, Y: Integer): Word; begin Result := FBits^[X + Y * Width]; end; procedure TWordMap.SetValue(X, Y: Integer; const Value: Word); begin FBits^[X + Y * Width] := Value; end; { TIntegerMap } constructor TIntegerMap.Create; begin FBits := nil; inherited Create; end; destructor TIntegerMap.Destroy; begin FreeMem(FBits); inherited; end; procedure TIntegerMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); begin ReallocMem(FBits, NewWidth * NewHeight * SizeOf(Integer)); Width := NewWidth; Height := NewHeight; end; procedure TIntegerMap.Clear(FillValue: Integer); begin FillLongword(FBits^, Width * Height, FillValue); Changed; end; procedure TIntegerMap.Assign(Source: TPersistent); begin BeginUpdate; try if Source is TIntegerMap then begin inherited SetSize(TIntegerMap(Source).Width, TIntegerMap(Source).Height); Move(TIntegerMap(Source).Bits[0], Bits[0], Width * Height * SizeOf(Integer)); end //else if Source is TBitmap32 then // ReadFrom(TBitmap32(Source), ctWeightedRGB) else inherited; finally EndUpdate; Changed; end; end; function TIntegerMap.Empty: Boolean; begin Result := not Assigned(FBits); end; function TIntegerMap.GetScanline(Y: Integer): PIntegerArray; begin Result := @FBits^[Y * Width]; end; function TIntegerMap.GetValPtr(X, Y: Integer): PInteger; begin Result := @FBits^[X + Y * Width]; end; function TIntegerMap.GetValue(X, Y: Integer): Integer; begin Result := FBits^[X + Y * Width]; end; procedure TIntegerMap.SetValue(X, Y: Integer; const Value: Integer); begin FBits^[X + Y * Width] := Value; end; { TCardinalMap } constructor TCardinalMap.Create; begin FBits := nil; inherited Create; end; destructor TCardinalMap.Destroy; begin FreeMem(FBits); inherited; end; procedure TCardinalMap.Assign(Source: TPersistent); begin BeginUpdate; try if Source is TCardinalMap then begin inherited SetSize(TCardinalMap(Source).Width, TCardinalMap(Source).Height); Move(TCardinalMap(Source).Bits[0], Bits[0], Width * Height * SizeOf(Cardinal)); end //else if Source is TBitmap32 then // ReadFrom(TBitmap32(Source), ctWeightedRGB) else inherited; finally EndUpdate; Changed; end; end; procedure TCardinalMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); begin ReallocMem(FBits, NewWidth * NewHeight * SizeOf(Cardinal)); Width := NewWidth; Height := NewHeight; end; procedure TCardinalMap.Clear(FillValue: Cardinal); begin FillLongword(FBits^, Width * Height, FillValue); Changed; end; function TCardinalMap.Empty: Boolean; begin Result := not Assigned(FBits); end; function TCardinalMap.GetScanline(Y: Integer): PCardinalArray; begin Result := @FBits^[Y * Width]; end; function TCardinalMap.GetValPtr(X, Y: Cardinal): PCardinal; begin Result := @FBits^[X + Y * Cardinal(Width)]; end; function TCardinalMap.GetValue(X, Y: Cardinal): Cardinal; begin Result := FBits^[X + Y * Cardinal(Width)]; end; procedure TCardinalMap.SetValue(X, Y: Cardinal; const Value: Cardinal); begin FBits^[X + Y * Cardinal(Width)] := Value; end; { TFloatMap } constructor TFloatMap.Create; begin FBits := nil; inherited Create; end; destructor TFloatMap.Destroy; begin FreeMem(FBits); inherited; end; procedure TFloatMap.Assign(Source: TPersistent); begin BeginUpdate; try if Source is TFloatMap then begin inherited SetSize(TFloatMap(Source).Width, TFloatMap(Source).Height); Move(TFloatMap(Source).Bits[0], Bits[0], Width * Height * SizeOf(TFloat)); end //else if Source is TBitmap32 then // ReadFrom(TBitmap32(Source), ctWeightedRGB) else inherited; finally EndUpdate; Changed; end; end; procedure TFloatMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); begin ReallocMem(FBits, NewWidth * NewHeight * SizeOf(TFloat)); Width := NewWidth; Height := NewHeight; end; procedure TFloatMap.Clear; begin FillChar(FBits^, Width * Height * SizeOf(TFloat), 0); Changed; end; procedure TFloatMap.Clear(FillValue: TFloat); var Index: Integer; begin for Index := 0 to Width * Height - 1 do FBits^[Index] := FillValue; Changed; end; function TFloatMap.Empty: Boolean; begin Result := not Assigned(FBits); end; function TFloatMap.GetScanline(Y: Integer): PFloatArray; begin Result := @FBits^[Y * Width]; end; function TFloatMap.GetValPtr(X, Y: Integer): PFloat; begin Result := @FBits^[X + Y * Width]; end; function TFloatMap.GetValue(X, Y: Integer): TFloat; begin Result := FBits^[X + Y * Width]; end; procedure TFloatMap.SetValue(X, Y: Integer; const Value: TFloat); begin FBits^[X + Y * Width] := Value; end; {$IFDEF COMPILER2010} { TGenericMap<T> } constructor TGenericMap<T>.Create; begin FBits := nil; inherited Create; end; destructor TGenericMap<T>.Destroy; begin FreeMem(FBits); inherited; end; procedure TGenericMap<T>.Assign(Source: TPersistent); begin BeginUpdate; try (* if Source is TFloatMap then begin inherited SetSize(TFloatMap(Source).Width, TFloatMap(Source).Height); Move(TFloatMap(Source).Bits[0], Bits[0], Width * Height * SizeOf(TFloat)); end //else if Source is TBitmap32 then // ReadFrom(TBitmap32(Source), ctWeightedRGB) else inherited; *) finally EndUpdate; Changed; end; end; procedure TGenericMap<T>.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); begin ReallocMem(FBits, NewWidth * NewHeight * SizeOf(T)); Width := NewWidth; Height := NewHeight; end; procedure TGenericMap<T>.Clear(FillValue: T); var Index: Integer; begin for Index := 0 to Width * Height - 1 do Move(FillValue, PByte(FBits)[Index], SizeOf(T)); Changed; end; procedure TGenericMap<T>.Clear; begin FillChar(FBits^, Width * Height * SizeOf(T), 0); Changed; end; function TGenericMap<T>.Empty: Boolean; begin Result := not Assigned(FBits); end; function TGenericMap<T>.GetValue(X, Y: Integer): T; begin Move(PByte(FBits)[(X + Y * Width) * SizeOf(T)], Result, SizeOf(T)); end; procedure TGenericMap<T>.SetValue(X, Y: Integer; const Value: T); begin Move(Value, PByte(FBits)[(X + Y * Width) * SizeOf(T)], SizeOf(T)); end; {$ENDIF} end. |
Added src/graphics32/GR32_Paths.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 | unit GR32_Paths; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Vectorial Polygon Rasterizer for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * * Portions created by the Initial Developer are Copyright (C) 2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Classes, SysUtils, GR32, GR32_Polygons, GR32_Transforms, GR32_Brushes, GR32_Geometry; const DefaultCircleSteps = 100; DefaultBezierTolerance = 0.25; type TControlPointOrigin = (cpNone, cpCubic, cpConic); { TCustomPath } TCustomPath = class(TThreadPersistent) private FCurrentPoint: TFloatPoint; FLastControlPoint: TFloatPoint; FControlPointOrigin: TControlPointOrigin; protected procedure AddPoint(const Point: TFloatPoint); virtual; procedure AssignTo(Dest: TPersistent); override; public constructor Create; override; procedure Clear; virtual; procedure MoveTo(const X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure MoveTo(const P: TFloatPoint); overload; virtual; procedure MoveToRelative(const X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure MoveToRelative(const P: TFloatPoint); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure LineTo(const X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure LineTo(const P: TFloatPoint); overload; virtual; procedure LineToRelative(const X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure LineToRelative(const P: TFloatPoint); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure HorizontalLineTo(const X: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure HorizontalLineToRelative(const X: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure VerticalLineTo(const Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure VerticalLineToRelative(const Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure CurveTo(const X1, Y1, X2, Y2, X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure CurveTo(const X2, Y2, X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure CurveTo(const C1, C2, P: TFloatPoint); overload; virtual; procedure CurveTo(const C2, P: TFloatPoint); overload; virtual; procedure CurveToRelative(const X1, Y1, X2, Y2, X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure CurveToRelative(const X2, Y2, X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure CurveToRelative(const C1, C2, P: TFloatPoint); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure CurveToRelative(const C2, P: TFloatPoint); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure ConicTo(const X1, Y1, X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure ConicTo(const P1, P: TFloatPoint); overload; virtual; procedure ConicTo(const X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure ConicTo(const P: TFloatPoint); overload; virtual; procedure ConicToRelative(const X1, Y1, X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure ConicToRelative(const P1, P: TFloatPoint); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure ConicToRelative(const X, Y: TFloat); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure ConicToRelative(const P: TFloatPoint); overload; {$IFDEF USEINLINING} inline; {$ENDIF} procedure BeginPath; virtual; procedure EndPath; virtual; procedure ClosePath; virtual; procedure Rectangle(const Rect: TFloatRect); virtual; procedure RoundRect(const Rect: TFloatRect; const Radius: TFloat); virtual; procedure Arc(const P: TFloatPoint; StartAngle, EndAngle, Radius: TFloat); virtual; procedure Ellipse(Rx, Ry: TFloat; Steps: Integer = DefaultCircleSteps); overload; virtual; procedure Ellipse(const Cx, Cy, Rx, Ry: TFloat; Steps: Integer = DefaultCircleSteps); overload; virtual; procedure Circle(const Cx, Cy, Radius: TFloat; Steps: Integer = DefaultCircleSteps); overload; virtual; procedure Circle(const Center: TFloatPoint; Radius: TFloat; Steps: Integer = DefaultCircleSteps); overload; virtual; procedure Polygon(const APoints: TArrayOfFloatPoint); virtual; property CurrentPoint: TFloatPoint read FCurrentPoint write FCurrentPoint; end; { TFlattenedPath } TFlattenedPath = class(TCustomPath) private FPath: TArrayOfArrayOfFloatPoint; FPoints: TArrayOfFloatPoint; FPointIndex: Integer; FOnBeginPath: TNotifyEvent; FOnEndPath: TNotifyEvent; FOnClosePath: TNotifyEvent; function GetPoints: TArrayOfFloatPoint; protected procedure AddPoint(const Point: TFloatPoint); override; procedure AssignTo(Dest: TPersistent); override; public procedure Clear; override; procedure DrawPath; virtual; procedure MoveTo(const P: TFloatPoint); override; procedure ClosePath; override; procedure BeginPath; override; procedure EndPath; override; procedure Polygon(const APoints: TArrayOfFloatPoint); override; property Points: TArrayOfFloatPoint read GetPoints; property Path: TArrayOfArrayOfFloatPoint read FPath; property OnBeginPath: TNotifyEvent read FOnBeginPath write FOnBeginPath; property OnEndPath: TNotifyEvent read FOnEndPath write FOnEndPath; property OnClosePath: TNotifyEvent read FOnClosePath write FOnClosePath; end; { TCustomCanvas } TCustomCanvas = class(TThreadPersistent) private FPath: TFlattenedPath; FTransformation: TTransformation; procedure SetTransformation(const Value: TTransformation); protected procedure DrawPath; virtual; abstract; procedure DoBeginPath(Sender: TObject); virtual; procedure DoEndPath(Sender: TObject); virtual; procedure DoClosePath(Sender: TObject); virtual; procedure AssignTo(Dest: TPersistent); override; public constructor Create; override; destructor Destroy; override; property Transformation: TTransformation read FTransformation write SetTransformation; property Path: TFlattenedPath read FPath; end; { TCanvas32 } TCanvas32 = class(TCustomCanvas) private FBitmap: TBitmap32; FRenderer: TPolygonRenderer32; FBrushes: TBrushCollection; function GetRendererClassName: string; procedure SetRendererClassName(const Value: string); procedure SetRenderer(ARenderer: TPolygonRenderer32); protected procedure AssignTo(Dest: TPersistent); override; procedure DrawPath; override; class function GetPolygonRendererClass: TPolygonRenderer32Class; virtual; procedure BrushCollectionChangeHandler(Sender: TObject); virtual; public constructor Create(ABitmap: TBitmap32); reintroduce; virtual; destructor Destroy; override; procedure RenderText(X, Y: TFloat; const Text: WideString); overload; procedure RenderText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal); overload; function MeasureText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; property Bitmap: TBitmap32 read FBitmap; property Renderer: TPolygonRenderer32 read FRenderer write SetRenderer; property RendererClassName: string read GetRendererClassName write SetRendererClassName; property Brushes: TBrushCollection read FBrushes; end; var CBezierTolerance: TFloat = 0.25; QBezierTolerance: TFloat = 0.25; type TAddPointEvent = procedure(const Point: TFloatPoint) of object; implementation uses Math, GR32_Backends, GR32_VectorUtils; function CubicBezierFlatness(const P1, P2, P3, P4: TFloatPoint): TFloat; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result := Abs(P1.X + P3.X - 2 * P2.X) + Abs(P1.Y + P3.Y - 2 * P2.Y) + Abs(P2.X + P4.X - 2 * P3.X) + Abs(P2.Y + P4.Y - 2 * P3.Y); end; function QuadraticBezierFlatness(const P1, P2, P3: TFloatPoint): TFloat; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result := Abs(P1.x + P3.x - 2 * P2.x) + Abs(P1.y + P3.y - 2 * P2.y); end; procedure CubicBezierCurve(const P1, P2, P3, P4: TFloatPoint; const AddPoint: TAddPointEvent; const Tolerance: TFloat); var P12, P23, P34, P123, P234, P1234: TFloatPoint; begin if CubicBezierFlatness(P1, P2, P3, P4) < Tolerance then AddPoint(P1) else begin P12.X := (P1.X + P2.X) * 0.5; P12.Y := (P1.Y + P2.Y) * 0.5; P23.X := (P2.X + P3.X) * 0.5; P23.Y := (P2.Y + P3.Y) * 0.5; P34.X := (P3.X + P4.X) * 0.5; P34.Y := (P3.Y + P4.Y) * 0.5; P123.X := (P12.X + P23.X) * 0.5; P123.Y := (P12.Y + P23.Y) * 0.5; P234.X := (P23.X + P34.X) * 0.5; P234.Y := (P23.Y + P34.Y) * 0.5; P1234.X := (P123.X + P234.X) * 0.5; P1234.Y := (P123.Y + P234.Y) * 0.5; CubicBezierCurve(P1, P12, P123, P1234, AddPoint, Tolerance); CubicBezierCurve(P1234, P234, P34, P4, AddPoint, Tolerance); end; end; procedure QuadraticBezierCurve(const P1, P2, P3: TFloatPoint; const AddPoint: TAddPointEvent; const Tolerance: TFloat); var P12, P23, P123: TFloatPoint; begin if QuadraticBezierFlatness(P1, P2, P3) < Tolerance then AddPoint(P1) else begin P12.X := (P1.X + P2.X) * 0.5; P12.Y := (P1.Y + P2.Y) * 0.5; P23.X := (P2.X + P3.X) * 0.5; P23.Y := (P2.Y + P3.Y) * 0.5; P123.X := (P12.X + P23.X) * 0.5; P123.Y := (P12.Y + P23.Y) * 0.5; QuadraticBezierCurve(P1, P12, P123, AddPoint, Tolerance); QuadraticBezierCurve(P123, P23, P3, AddPoint, Tolerance); end; end; //============================================================================// { TCustomPath } constructor TCustomPath.Create; begin inherited; FControlPointOrigin := cpNone; end; procedure TCustomPath.AddPoint(const Point: TFloatPoint); begin end; procedure TCustomPath.Arc(const P: TFloatPoint; StartAngle, EndAngle, Radius: TFloat); begin Polygon(BuildArc(P, StartAngle, EndAngle, Radius)); end; procedure TCustomPath.AssignTo(Dest: TPersistent); begin if Dest is TCustomPath then with TCustomPath(Dest) do begin FCurrentPoint := Self.FCurrentPoint; FLastControlPoint := Self.FLastControlPoint; FControlPointOrigin := Self.FControlPointOrigin; end else inherited; end; procedure TCustomPath.BeginPath; begin end; procedure TCustomPath.Circle(const Cx, Cy, Radius: TFloat; Steps: Integer); begin Polygon(GR32_VectorUtils.Circle(Cx, Cy, Radius, Steps)); end; procedure TCustomPath.Circle(const Center: TFloatPoint; Radius: TFloat; Steps: Integer); begin Polygon(GR32_VectorUtils.Circle(Center.X, Center.Y, Radius, Steps)); end; procedure TCustomPath.Clear; begin FControlPointOrigin := cpNone; end; procedure TCustomPath.ClosePath; begin end; procedure TCustomPath.ConicTo(const P1, P: TFloatPoint); begin QuadraticBezierCurve(FCurrentPoint, P1, P, AddPoint, QBezierTolerance); AddPoint(P); FCurrentPoint := P; FLastControlPoint := P1; FControlPointOrigin := cpConic; end; procedure TCustomPath.ConicTo(const X1, Y1, X, Y: TFloat); begin ConicTo(FloatPoint(X1, Y1), FloatPoint(X, Y)); end; procedure TCustomPath.ConicTo(const X, Y: TFloat); begin ConicTo(FloatPoint(X, Y)); end; procedure TCustomPath.ConicTo(const P: TFloatPoint); var P1: TFloatPoint; begin if FControlPointOrigin = cpConic then begin P1.X := FCurrentPoint.X + (FCurrentPoint.X - FLastControlPoint.X); P1.Y := FCurrentPoint.Y + (FCurrentPoint.Y - FLastControlPoint.Y); end else P1 := FCurrentPoint; ConicTo(P1, P); end; procedure TCustomPath.ConicToRelative(const X, Y: TFloat); begin ConicTo(FloatPoint(FCurrentPoint.X + X, FCurrentPoint.Y + Y)); end; procedure TCustomPath.ConicToRelative(const P: TFloatPoint); begin ConicTo(OffsetPoint(P, FCurrentPoint)); end; procedure TCustomPath.ConicToRelative(const X1, Y1, X, Y: TFloat); begin ConicTo(FloatPoint(FCurrentPoint.X + X1, FCurrentPoint.Y + Y1), FloatPoint(FCurrentPoint.X + X, FCurrentPoint.Y + Y)); end; procedure TCustomPath.ConicToRelative(const P1, P: TFloatPoint); begin ConicTo(OffsetPoint(P1, FCurrentPoint), OffsetPoint(P, FCurrentPoint)); end; procedure TCustomPath.CurveTo(const C1, C2, P: TFloatPoint); begin CubicBezierCurve(FCurrentPoint, C1, C2, P, AddPoint, CBezierTolerance); AddPoint(P); FCurrentPoint := P; FLastControlPoint := C2; FControlPointOrigin := cpCubic; end; procedure TCustomPath.CurveTo(const X1, Y1, X2, Y2, X, Y: TFloat); begin CurveTo(FloatPoint(X1, Y1), FloatPoint(X2, Y2), FloatPoint(X, Y)); end; procedure TCustomPath.CurveTo(const X2, Y2, X, Y: TFloat); begin CurveTo(FloatPoint(X2, Y2), FloatPoint(X, Y)); end; procedure TCustomPath.CurveTo(const C2, P: TFloatPoint); var C1: TFloatPoint; begin if FControlPointOrigin = cpCubic then begin C1.X := FCurrentPoint.X - (FLastControlPoint.X - FCurrentPoint.X); C1.Y := FCurrentPoint.Y - (FLastControlPoint.Y - FCurrentPoint.Y); end else C1 := FCurrentPoint; CurveTo(C1, C2, P); end; procedure TCustomPath.CurveToRelative(const X1, Y1, X2, Y2, X, Y: TFloat); begin CurveTo(FloatPoint(FCurrentPoint.X + X1, FCurrentPoint.Y + Y1), FloatPoint(FCurrentPoint.X + X2, FCurrentPoint.Y + Y2), FloatPoint(FCurrentPoint.X + X, FCurrentPoint.Y + Y)); end; procedure TCustomPath.CurveToRelative(const X2, Y2, X, Y: TFloat); begin CurveTo(FloatPoint(FCurrentPoint.X + X2, FCurrentPoint.Y + Y2), FloatPoint(FCurrentPoint.X + X, FCurrentPoint.Y + Y)); end; procedure TCustomPath.CurveToRelative(const C1, C2, P: TFloatPoint); begin CurveTo(OffsetPoint(C1, FCurrentPoint), OffsetPoint(C2, FCurrentPoint), OffsetPoint(P, FCurrentPoint)); end; procedure TCustomPath.CurveToRelative(const C2, P: TFloatPoint); begin CurveTo(OffsetPoint(C2, FCurrentPoint), OffsetPoint(P, FCurrentPoint)); end; procedure TCustomPath.Ellipse(const Cx, Cy, Rx, Ry: TFloat; Steps: Integer); begin Polygon(GR32_VectorUtils.Ellipse(Cx, Cy, Rx, Ry, Steps)); end; procedure TCustomPath.Ellipse(Rx, Ry: TFloat; Steps: Integer); begin with FCurrentPoint do Ellipse(X, Y, Rx, Ry); end; procedure TCustomPath.EndPath; begin end; procedure TCustomPath.HorizontalLineTo(const X: TFloat); begin LineTo(FloatPoint(X, FCurrentPoint.Y)); end; procedure TCustomPath.HorizontalLineToRelative(const X: TFloat); begin LineTo(FloatPoint(FCurrentPoint.X + X, FCurrentPoint.Y)); end; procedure TCustomPath.LineTo(const X, Y: TFloat); begin LineTo(FloatPoint(X, Y)); end; procedure TCustomPath.LineTo(const P: TFloatPoint); begin AddPoint(P); FCurrentPoint := P; FControlPointOrigin := cpNone; end; procedure TCustomPath.LineToRelative(const X, Y: TFloat); begin LineTo(FloatPoint(FCurrentPoint.X + X, FCurrentPoint.Y + Y)); end; procedure TCustomPath.LineToRelative(const P: TFloatPoint); begin LineTo(FloatPoint(FCurrentPoint.X + P.X, FCurrentPoint.Y + P.Y)); end; procedure TCustomPath.MoveTo(const X, Y: TFloat); begin MoveTo(FloatPoint(X, Y)); end; procedure TCustomPath.MoveToRelative(const X, Y: TFloat); begin MoveTo(FloatPoint(FCurrentPoint.X + X, FCurrentPoint.Y + Y)); end; procedure TCustomPath.MoveToRelative(const P: TFloatPoint); begin MoveTo(FloatPoint(FCurrentPoint.X + P.X, FCurrentPoint.Y + P.Y)); end; procedure TCustomPath.Rectangle(const Rect: TFloatRect); begin Polygon(GR32_VectorUtils.Rectangle(Rect)); end; procedure TCustomPath.RoundRect(const Rect: TFloatRect; const Radius: TFloat); begin Polygon(GR32_VectorUtils.RoundRect(Rect, Radius)); end; procedure TCustomPath.VerticalLineTo(const Y: TFloat); begin LineTo(FloatPoint(FCurrentPoint.X, Y)); end; procedure TCustomPath.VerticalLineToRelative(const Y: TFloat); begin LineTo(FloatPoint(FCurrentPoint.X, FCurrentPoint.Y + Y)); end; procedure TCustomPath.Polygon(const APoints: TArrayOfFloatPoint); var I: Integer; begin ClosePath; MoveTo(APoints[0]); for I := 1 to High(APoints) do LineTo(APoints[I]); ClosePath; EndPath; end; procedure TCustomPath.MoveTo(const P: TFloatPoint); begin FCurrentPoint := P; FControlPointOrigin := cpNone; end; { TFlattenedPath } procedure TFlattenedPath.BeginPath; begin FPath := nil; FPoints := nil; FPointIndex := 0; if Assigned(FOnBeginPath) then FOnBeginPath(Self); end; procedure TFlattenedPath.EndPath; begin if Assigned(FOnEndPath) then FOnEndPath(Self); end; procedure TFlattenedPath.Clear; begin inherited; FPath := nil; FPoints := nil; FPointIndex := 0; end; procedure TFlattenedPath.ClosePath; var N: Integer; begin if Length(FPoints) <> 0 then begin FCurrentPoint := FPoints[0]; N := Length(FPath); SetLength(FPath, N + 1); FPath[N] := Copy(FPoints, 0, FPointIndex); FPoints := nil; FPointIndex := 0; end; if Assigned(FOnClosePath) then FOnClosePath(Self); end; procedure TFlattenedPath.MoveTo(const P: TFloatPoint); begin inherited; if Length(FPoints) <> 0 then ClosePath; AddPoint(P); end; procedure TFlattenedPath.Polygon(const APoints: TArrayOfFloatPoint); var I: Integer; begin if Length(APoints) = 0 then Exit; ClosePath; for I := 0 to High(APoints) do AddPoint(APoints[I]); FCurrentPoint := APoints[High(APoints)]; ClosePath; EndPath; end; procedure TFlattenedPath.AddPoint(const Point: TFloatPoint); const BUFFSIZEINCREMENT = 128; var L: Integer; begin L := Length(FPoints); if FPointIndex >= L then SetLength(FPoints, L + BUFFSIZEINCREMENT); FPoints[FPointIndex] := Point; Inc(FPointIndex); end; procedure TFlattenedPath.AssignTo(Dest: TPersistent); var I: Integer; begin inherited; if Dest is TFlattenedPath then with TFlattenedPath(Dest) do begin BeginPath; SetLength(FPath, Length(Self.FPath)); for I := 0 to High(Self.FPath) do begin SetLength(FPath[I], Length(Self.FPath[I])); Move(Self.FPath[I, 0], FPath[I, 0], Length(Self.FPath[I]) * SizeOf(TFloatPoint)); end; EndPath; end; end; function TFlattenedPath.GetPoints: TArrayOfFloatPoint; begin Result := Copy(FPoints, 0, FPointIndex); end; procedure TFlattenedPath.DrawPath; begin // implemented by descendants end; { TCustomCanvas } constructor TCustomCanvas.Create; begin FPath := TFlattenedPath.Create; FPath.OnBeginPath := DoBeginPath; FPath.OnEndPath := DoEndPath; FPath.OnClosePath := DoClosePath; end; destructor TCustomCanvas.Destroy; begin FPath.Free; inherited; end; procedure TCustomCanvas.AssignTo(Dest: TPersistent); begin if Dest is TCustomCanvas then with TCustomCanvas(Dest) do begin FPath.Assign(Self.FPath); FTransformation := Self.FTransformation; end else inherited; end; procedure TCustomCanvas.DoBeginPath(Sender: TObject); begin end; procedure TCustomCanvas.DoClosePath(Sender: TObject); begin end; procedure TCustomCanvas.DoEndPath(Sender: TObject); begin DrawPath; end; procedure TCustomCanvas.SetTransformation(const Value: TTransformation); begin if FTransformation <> Value then begin FTransformation := Value; Changed; end; end; { TCanvas32 } procedure TCanvas32.AssignTo(Dest: TPersistent); begin inherited; if Dest is TCanvas32 then with TCanvas32(Dest) do begin FBitmap := Self.Bitmap; FRenderer.Assign(Self.FRenderer); FBrushes.Assign(Self.FBrushes); end; end; procedure TCanvas32.BrushCollectionChangeHandler(Sender: TObject); begin Changed; end; constructor TCanvas32.Create(ABitmap: TBitmap32); begin inherited Create; FBitmap := ABitmap; FRenderer := GetPolygonRendererClass.Create; FRenderer.Bitmap := ABitmap; FBrushes := TBrushCollection.Create(Self); FBrushes.OnChange := BrushCollectionChangeHandler; end; destructor TCanvas32.Destroy; begin FBrushes.Free; FRenderer.Free; inherited; end; procedure TCanvas32.DrawPath; var ClipRect: TFloatRect; I: Integer; P: TArrayOfFloatPoint; begin ClipRect := FloatRect(Bitmap.ClipRect); Renderer.Bitmap := Bitmap; P := Path.Points; for I := 0 to FBrushes.Count - 1 do begin with FBrushes[I] do if Visible then begin PolyPolygonFS(Renderer, Path.Path, ClipRect, Transformation, True); if Length(P) > 0 then PolygonFS(Renderer, P, ClipRect, Transformation, False); end; end; end; class function TCanvas32.GetPolygonRendererClass: TPolygonRenderer32Class; begin Result := DefaultPolygonRendererClass; end; function TCanvas32.GetRendererClassName: string; begin Result := FRenderer.ClassName; end; function TCanvas32.MeasureText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; var Intf: ITextToPathSupport; begin if Supports(Bitmap.Backend, ITextToPathSupport, Intf) then Result := Intf.MeasureText(DstRect, Text, Flags) else raise Exception.Create(RCStrInpropriateBackend); end; procedure TCanvas32.RenderText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal); var Intf: ITextToPathSupport; begin if Supports(Bitmap.Backend, ITextToPathSupport, Intf) then Intf.TextToPath(Path, DstRect, Text, Flags) else raise Exception.Create(RCStrInpropriateBackend); end; procedure TCanvas32.RenderText(X, Y: TFloat; const Text: WideString); var Intf: ITextToPathSupport; begin if Supports(Bitmap.Backend, ITextToPathSupport, Intf) then Intf.TextToPath(Path, X, Y, Text) else raise Exception.Create(RCStrInpropriateBackend); end; procedure TCanvas32.SetRenderer(ARenderer: TPolygonRenderer32); begin if Assigned(ARenderer) and (FRenderer <> ARenderer) then begin if Assigned(FRenderer) then FRenderer.Free; FRenderer := ARenderer; Changed; end; end; procedure TCanvas32.SetRendererClassName(const Value: string); var RendererClass: TPolygonRenderer32Class; begin if (Value <> '') and (FRenderer.ClassName <> Value) and Assigned(PolygonRendererList) then begin RendererClass := TPolygonRenderer32Class(PolygonRendererList.Find(Value)); if Assigned(RendererClass) then Renderer := RendererClass.Create; end; end; end. |
Added src/graphics32/GR32_Polygons.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 | unit GR32_Polygons; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Vectorial Polygon Rasterizer for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * * Portions created by the Initial Developer are Copyright (C) 2008-2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Types, GR32, GR32_Containers, GR32_VPR, GR32_Transforms, GR32_Resamplers; type { Polygon join style } TJoinStyle = (jsMiter, jsBevel, jsRound); { Polygon end style } TEndStyle = (esButt, esSquare, esRound); { Polygon fill mode } TPolyFillMode = (pfAlternate, pfWinding, pfEvenOdd = 0, pfNonZero); { TCustomPolygonRenderer } TCustomPolygonRenderer = class(TThreadPersistent) public procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation); overload; virtual; procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); overload; virtual; procedure PolygonFS(const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation); overload; virtual; procedure PolygonFS(const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect); overload; virtual; // procedure PolyPolygonXS(const Points: TArrayOfArrayOfFixedPoint; const ClipRect: TFixedRect; Transformation: TTransformation); virtual; overload; // procedure PolyPolygonXS(const Points: TArrayOfArrayOfFixedPoint; const ClipRect: TFixedRect); virtual; overload; end; TCustomPolygonRendererClass = class of TCustomPolygonRenderer; TCustomPolygonFiller = class; { TPolygonRenderer32 } TPolygonRenderer32 = class(TCustomPolygonRenderer) private FBitmap: TBitmap32; FFillMode: TPolyFillMode; FColor: TColor32; FFiller: TCustomPolygonFiller; procedure SetColor(const Value: TColor32); procedure SetFillMode(const Value: TPolyFillMode); procedure SetFiller(const Value: TCustomPolygonFiller); protected procedure SetBitmap(const Value: TBitmap32); virtual; public constructor Create(Bitmap: TBitmap32; Fillmode: TPolyFillMode = pfWinding); reintroduce; overload; procedure PolygonFS(const Points: TArrayOfFloatPoint); overload; virtual; procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint); overload; virtual; property Bitmap: TBitmap32 read FBitmap write SetBitmap; property FillMode: TPolyFillMode read FFillMode write SetFillMode; property Color: TColor32 read FColor write SetColor; property Filler: TCustomPolygonFiller read FFiller write SetFiller; end; TPolygonRenderer32Class = class of TPolygonRenderer32; { TPolygonRenderer32VPR } { Polygon renderer based on VPR. Computes exact coverages for optimal anti-aliasing. } TFillProc = procedure(Coverage: PSingleArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); TPolygonRenderer32VPR = class(TPolygonRenderer32) private FFillProc: TFillProc; procedure UpdateFillProcs; protected procedure RenderSpan(const Span: TValueSpan; DstY: Integer); virtual; procedure FillSpan(const Span: TValueSpan; DstY: Integer); virtual; function GetRenderSpan: TRenderSpanEvent; virtual; public procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); override; end; { TPolygonRenderer32LCD } TPolygonRenderer32LCD = class(TPolygonRenderer32VPR) protected procedure RenderSpan(const Span: TValueSpan; DstY: Integer); override; public procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); override; end; { TPolygonRenderer32LCD2 } TPolygonRenderer32LCD2 = class(TPolygonRenderer32LCD) public procedure RenderSpan(const Span: TValueSpan; DstY: Integer); override; end; { TCustomPolygonFiller } TFillLineEvent = procedure(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32) of object; TCustomPolygonFiller = class private protected function GetFillLine: TFillLineEvent; virtual; abstract; public procedure BeginRendering; virtual; procedure EndRendering; virtual; property FillLine: TFillLineEvent read GetFillLine; end; { TCallbackPolygonFiller } TCallbackPolygonFiller = class(TCustomPolygonFiller) private FFillLineEvent: TFillLineEvent; protected function GetFillLine: TFillLineEvent; override; public property FillLineEvent: TFillLineEvent read FFillLineEvent write FFillLineEvent; end; { TInvertPolygonFiller } TInvertPolygonFiller = class(TCustomPolygonFiller) protected function GetFillLine: TFillLineEvent; override; procedure FillLineBlend(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); end; { TBitmapPolygonFiller } TBitmapPolygonFiller = class(TCustomPolygonFiller) private FPattern: TCustomBitmap32; FOffsetY: Integer; FOffsetX: Integer; protected function GetFillLine: TFillLineEvent; override; procedure FillLineOpaque(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineBlend(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineBlendMasterAlpha(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); procedure FillLineCustomCombine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); public property Pattern: TCustomBitmap32 read FPattern write FPattern; property OffsetX: Integer read FOffsetX write FOffsetX; property OffsetY: Integer read FOffsetY write FOffsetY; end; { TSamplerFiller } TSamplerFiller = class(TCustomPolygonFiller) private FSampler: TCustomSampler; FGetSample: TGetSampleInt; procedure SetSampler(const Value: TCustomSampler); protected procedure SamplerChanged; virtual; function GetFillLine: TFillLineEvent; override; procedure SampleLineOpaque(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); public constructor Create(Sampler: TCustomSampler = nil); reintroduce; virtual; procedure BeginRendering; override; procedure EndRendering; override; property Sampler: TCustomSampler read FSampler write SetSampler; end; procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolylineFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; procedure PolyPolylineFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; procedure PolylineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; procedure PolylineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; //Filled only Dashes ... procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Color: TColor32; Closed: Boolean = False; Width: TFloat = 1.0); overload; procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; FillColor, StrokeColor: TColor32; Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); overload; //Filled and stroked Dashes ... procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; Closed: Boolean = False; Width: TFloat = 1.0); overload; procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; StrokeColor: TColor32; Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); overload; procedure PolyPolygonXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonXS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonXS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); procedure PolyPolygonXS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonXS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); procedure PolyPolylineXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; Closed: Boolean = False; StrokeWidth: TFixed = $10000; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFixed = $40000; Transformation: TTransformation = nil); overload; procedure PolyPolylineXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFixed = $10000; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFixed = $40000; Transformation: TTransformation = nil); overload; procedure PolylineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Color: TColor32; Closed: Boolean = False; StrokeWidth: TFixed = $10000; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFixed = $40000; Transformation: TTransformation = nil); overload; procedure PolylineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFixed = $10000; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFixed = $40000; Transformation: TTransformation = nil); overload; //Filled only Dashes ... procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; const Dashes: TArrayOfFixed; Color: TColor32; Closed: Boolean = False; Width: TFixed = $10000); overload; procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; const Dashes: TArrayOfFixed; FillColor, StrokeColor: TColor32; Closed: Boolean; Width: TFixed; StrokeWidth: TFixed = $20000); overload; //Filled and stroked Dashes ... procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; const Dashes: TArrayOfFixed; Filler: TCustomPolygonFiller; Closed: Boolean = False; Width: TFixed = $10000); overload; procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; const Dashes: TArrayOfFixed; Filler: TCustomPolygonFiller; StrokeColor: TColor32; Closed: Boolean; Width: TFixed; StrokeWidth: TFixed = $20000); overload; // fill entire bitmap with a given polygon filler procedure FillBitmap(Bitmap: TBitmap32; Filler: TCustomPolygonFiller); { Registration routines } procedure RegisterPolygonRenderer(PolygonRendererClass: TCustomPolygonRendererClass); var PolygonRendererList: TClassList; DefaultPolygonRendererClass: TPolygonRenderer32Class = TPolygonRenderer32VPR; implementation uses Math, SysUtils, GR32_Math, GR32_LowLevel, GR32_Blend, GR32_VectorUtils; resourcestring RCStrNoSamplerSpecified = 'No sampler specified!'; type TBitmap32Access = class(TBitmap32); procedure RegisterPolygonRenderer(PolygonRendererClass: TCustomPolygonRendererClass); begin if not Assigned(PolygonRendererList) then PolygonRendererList := TClassList.Create; PolygonRendererList.Add(PolygonRendererClass); end; // routines for color filling: procedure MakeAlphaNonZeroUP(Coverage: PSingleArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var I: Integer; M, V: Cardinal; Last: TFloat; C: TColor32Entry absolute Color; begin M := C.A * $101; Last := Infinity; for I := 0 to Count - 1 do begin if PInteger(@Last)^ <> PInteger(@Coverage[I])^ then begin Last := Coverage[I]; V := Abs(Round(Last * $10000)); if V > $10000 then V := $10000; V := V * M shr 24; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} C.A := V; end; AlphaValues[I] := Color; end; end; (* procedure MakeAlphaNonZeroUP(Coverage: PSingleArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var I: Integer; M, V, C: Cardinal; begin M := Color shr 24 * $101; C := Color and $00ffffff; for I := 0 to Count - 1 do begin V := Abs(Round(Coverage[I] * $10000)); if V > $10000 then V := $10000; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V * M shr 24]; AlphaValues[I] := (V shl 24) or C; {$ELSE} AlphaValues[I] := (V * M and $ff000000) or C; {$ENDIF} end; end; *) procedure MakeAlphaEvenOddUP(Coverage: PSingleArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var I: Integer; M, V: Cardinal; Last: TFloat; C: TColor32Entry absolute Color; begin M := C.A * $101; Last := Infinity; for I := 0 to Count - 1 do begin if PInteger(@Last)^ <> PInteger(@Coverage[I])^ then begin Last := Coverage[I]; V := Abs(Round(Coverage[I] * $10000)); V := V and $01ffff; if V >= $10000 then V := V xor $1ffff; V := V * M shr 24; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} C.A := V; end; AlphaValues[I] := Color; end; end; procedure MakeAlphaNonZeroP(Value: Single; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var M, V: Cardinal; C: TColor32Entry absolute Color; begin M := C.A * $101; V := Abs(Round(Value * $10000)); if V > $10000 then V := $10000; V := V * M shr 24; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} C.A := V; FillLongWord(AlphaValues[0], Count, Color); end; procedure MakeAlphaEvenOddP(Value: Single; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var M, V: Cardinal; C: TColor32Entry absolute Color; begin M := C.A * $101; V := Abs(Round(Value * $10000)); V := V and $01ffff; if V > $10000 then V := V xor $1ffff; V := V * M shr 24; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} C.A := V; FillLongWord(AlphaValues[0], Count, Color); end; // polygon filler routines (extract alpha only): procedure MakeAlphaNonZeroUPF(Coverage: PSingleArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var I: Integer; V: Integer; begin for I := 0 to Count - 1 do begin V := Clamp(Round(Abs(Coverage[I]) * 256)); {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} AlphaValues[I] := V; end; end; procedure MakeAlphaEvenOddUPF(Coverage: PSingleArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var I: Integer; V: Integer; begin for I := 0 to Count - 1 do begin V := Round(Abs(Coverage[I]) * 256); V := V and $000001ff; if V >= $100 then V := V xor $1ff; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} AlphaValues[I] := V; end; end; procedure MakeAlphaNonZeroPF(Value: Single; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var V: Integer; begin V := Clamp(Round(Abs(Value) * 256)); {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} FillLongWord(AlphaValues[0], Count, V); end; procedure MakeAlphaEvenOddPF(Value: Single; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var V: Integer; begin V := Round(Abs(Value) * 256); V := V and $000001ff; if V >= $100 then V := V xor $1ff; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} FillLongWord(AlphaValues[0], Count, V); end; procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; begin Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Color := Color; Renderer.FillMode := FillMode; Renderer.PolyPolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; begin Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Color := Color; Renderer.FillMode := FillMode; Renderer.PolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; begin if not Assigned(Filler) then Exit; Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Filler := Filler; Renderer.FillMode := FillMode; Renderer.PolyPolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; begin if not Assigned(Filler) then Exit; Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Filler := Filler; Renderer.FillMode := FillMode; Renderer.PolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD; begin Renderer := TPolygonRenderer32LCD.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; Renderer.PolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD; begin Renderer := TPolygonRenderer32LCD.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; Renderer.PolyPolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD2; begin Renderer := TPolygonRenderer32LCD2.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; Renderer.PolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD2; begin Renderer := TPolygonRenderer32LCD2.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; Renderer.PolyPolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; IntersectedClipRect: TRect; begin Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Color := Color; Renderer.FillMode := FillMode; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolyPolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; IntersectedClipRect: TRect; begin Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Color := Color; Renderer.FillMode := FillMode; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; IntersectedClipRect: TRect; begin if not Assigned(Filler) then Exit; Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Filler := Filler; Renderer.FillMode := FillMode; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolyPolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; IntersectedClipRect: TRect; begin if not Assigned(Filler) then Exit; Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Filler := Filler; Renderer.FillMode := FillMode; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD; IntersectedClipRect: TRect; begin Renderer := TPolygonRenderer32LCD.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD; IntersectedClipRect: TRect; begin Renderer := TPolygonRenderer32LCD.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolyPolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD2; IntersectedClipRect: TRect; begin Renderer := TPolygonRenderer32LCD2.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD2; IntersectedClipRect: TRect; begin Renderer := TPolygonRenderer32LCD2.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolyPolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolylineFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; Closed: Boolean; StrokeWidth: TFloat; JoinStyle: TJoinStyle; EndStyle: TEndStyle; MiterLimit: TFloat; Transformation: TTransformation); var Dst: TArrayOfArrayOfFloatPoint; begin Dst := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit); PolyPolygonFS(Bitmap, Dst, Color, pfWinding, Transformation); end; procedure PolyPolylineFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); var Dst: TArrayOfArrayOfFloatPoint; begin Dst := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit); PolyPolygonFS(Bitmap, Dst, Filler, pfWinding, Transformation); end; procedure PolylineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; Closed: Boolean; StrokeWidth: TFloat; JoinStyle: TJoinStyle; EndStyle: TEndStyle; MiterLimit: TFloat; Transformation: TTransformation); begin PolyPolylineFS(Bitmap, PolyPolygon(Points), Color, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit, Transformation); end; procedure PolylineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); begin PolyPolylineFS(Bitmap, PolyPolygon(Points), Filler, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit, Transformation); end; procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Color: TColor32; Closed: Boolean = False; Width: TFloat = 1.0); var MultiPoly: TArrayOfArrayOfFloatPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); PolyPolylineFS(Bitmap, MultiPoly, Color, False, Width); end; procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; FillColor, StrokeColor: TColor32; Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); var MultiPoly: TArrayOfArrayOfFloatPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); MultiPoly := BuildPolyPolyLine(MultiPoly, False, Width); PolyPolygonFS(Bitmap, MultiPoly, FillColor); PolyPolylineFS(Bitmap, MultiPoly, StrokeColor, True, StrokeWidth); end; procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; Closed: Boolean = False; Width: TFloat = 1.0); var MultiPoly: TArrayOfArrayOfFloatPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); PolyPolylineFS(Bitmap, MultiPoly, Filler, False, Width); end; procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; StrokeColor: TColor32; Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); var MultiPoly: TArrayOfArrayOfFloatPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); MultiPoly := BuildPolyPolyLine(MultiPoly, False, Width); PolyPolygonFS(Bitmap, MultiPoly, Filler); PolyPolylineFS(Bitmap, MultiPoly, StrokeColor, True, StrokeWidth); end; procedure PolyPolygonXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; begin Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Color := Color; Renderer.FillMode := FillMode; Renderer.PolyPolygonFS(FixedPointToFloatPoint(Points), FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; begin Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Color := Color; Renderer.FillMode := FillMode; Renderer.PolygonFS(FixedPointToFloatPoint(Points), FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; begin Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Filler := Filler; Renderer.FillMode := FillMode; Renderer.PolyPolygonFS(FixedPointToFloatPoint(Points), FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32VPR; begin Renderer := TPolygonRenderer32VPR.Create; try Renderer.Bitmap := Bitmap; Renderer.Filler := Filler; Renderer.FillMode := FillMode; Renderer.PolygonFS(FixedPointToFloatPoint(Points), FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonXS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD; begin Renderer := TPolygonRenderer32LCD.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; Renderer.PolygonFS(FixedPointToFloatPoint(Points), FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonXS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD; begin Renderer := TPolygonRenderer32LCD.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; Renderer.PolyPolygonFS(FixedPointToFloatPoint(Points), FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonXS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD2; begin Renderer := TPolygonRenderer32LCD2.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; Renderer.PolygonFS(FixedPointToFloatPoint(Points), FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonXS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32LCD2; begin Renderer := TPolygonRenderer32LCD2.Create; try Renderer.Bitmap := Bitmap; Renderer.FillMode := FillMode; Renderer.Color := Color; Renderer.PolyPolygonFS(FixedPointToFloatPoint(Points), FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolylineXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; Closed: Boolean; StrokeWidth: TFixed; JoinStyle: TJoinStyle; EndStyle: TEndStyle; MiterLimit: TFixed; Transformation: TTransformation); var Dst: TArrayOfArrayOfFixedPoint; begin Dst := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit); PolyPolygonXS(Bitmap, Dst, Color, pfWinding, Transformation); end; procedure PolyPolylineXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFixed = $10000; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFixed = $40000; Transformation: TTransformation = nil); var Dst: TArrayOfArrayOfFixedPoint; begin Dst := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit); PolyPolygonXS(Bitmap, Dst, Filler, pfWinding, Transformation); end; procedure PolylineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Color: TColor32; Closed: Boolean; StrokeWidth: TFixed; JoinStyle: TJoinStyle; EndStyle: TEndStyle; MiterLimit: TFixed; Transformation: TTransformation); begin PolyPolylineXS(Bitmap, PolyPolygon(Points), Color, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit, Transformation); end; procedure PolylineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFixed = $10000; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFixed = $40000; Transformation: TTransformation = nil); begin PolyPolylineXS(Bitmap, PolyPolygon(Points), Filler, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit, Transformation); end; procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; const Dashes: TArrayOfFixed; Color: TColor32; Closed: Boolean = False; Width: TFixed = $10000); var MultiPoly: TArrayOfArrayOfFixedPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); PolyPolylineXS(Bitmap, MultiPoly, Color, False, Width); end; procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; const Dashes: TArrayOfFixed; FillColor, StrokeColor: TColor32; Closed: Boolean; Width: TFixed; StrokeWidth: TFixed = $20000); var MultiPoly: TArrayOfArrayOfFixedPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); PolyPolylineXS(Bitmap, MultiPoly, FillColor, False, Width); MultiPoly := BuildPolyPolyLine(MultiPoly, False, Width); PolyPolylineXS(Bitmap, MultiPoly, StrokeColor, True, strokeWidth); end; procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; const Dashes: TArrayOfFixed; Filler: TCustomPolygonFiller; Closed: Boolean = False; Width: TFixed = $10000); var MultiPoly: TArrayOfArrayOfFixedPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); PolyPolylineXS(Bitmap, MultiPoly, Filler, False, Width); end; procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; const Dashes: TArrayOfFixed; Filler: TCustomPolygonFiller; StrokeColor: TColor32; Closed: Boolean; Width: TFixed; StrokeWidth: TFixed = $20000); var MultiPoly: TArrayOfArrayOfFixedPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); PolyPolylineXS(Bitmap, MultiPoly, Filler, False, Width); MultiPoly := BuildPolyPolyLine(MultiPoly, False, Width); PolyPolylineXS(Bitmap, MultiPoly, StrokeColor, True, StrokeWidth); end; procedure FillBitmap(Bitmap: TBitmap32; Filler: TCustomPolygonFiller); var AlphaValues: PColor32; Y: Integer; begin {$IFDEF USESTACKALLOC} AlphaValues := StackAlloc(Bitmap.Width * SizeOf(TColor32)); {$ELSE} GetMem(AlphaValues, Bitmap.Width * SizeOf(TColor32)); {$ENDIF} FillLongword(AlphaValues^, Bitmap.Width, $FF); Filler.BeginRendering; for Y := 0 to Bitmap.Height - 1 do Filler.FillLine(PColor32(Bitmap.ScanLine[y]), 0, y, Bitmap.Width, AlphaValues); Filler.EndRendering; {$IFDEF USESTACKALLOC} StackFree(AlphaValues); {$ELSE} FreeMem(AlphaValues); {$ENDIF} end; { LCD sub-pixel rendering (see http://www.grc.com/cttech.htm) } type PRGBTriple = ^TRGBTriple; TRGBTriple = packed record B, G, R: Byte; end; PRGBTripleArray = ^TRGBTripleArray; TRGBTripleArray = array [0..0] of TRGBTriple; TMakeAlphaProcLCD = procedure(Coverage: PSingleArray; AlphaValues: SysUtils.PByteArray; Count: Integer; Color: TColor32); procedure MakeAlphaNonZeroLCD(Coverage: PSingleArray; AlphaValues: SysUtils.PByteArray; Count: Integer; Color: TColor32); var I: Integer; M, V: Cardinal; Last: TFloat; C: TColor32Entry absolute Color; begin M := C.A * 86; // 86 = 258 / 3 Last := Infinity; V := 0; AlphaValues[0] := 0; AlphaValues[1] := 0; for I := 0 to Count - 1 do begin if PInteger(@Last)^ <> PInteger(@Coverage[I])^ then begin Last := Coverage[I]; V := Abs(Round(Last * $10000)); if V > $10000 then V := $10000; V := V * M shr 24; end; Inc(AlphaValues[I], V); {$IFDEF USEGR32GAMMA} AlphaValues[I] := GAMMA_TABLE[AlphaValues[I]]; {$ENDIF} Inc(AlphaValues[I + 1], V); AlphaValues[I + 2] := V; end; AlphaValues[Count + 2] := 0; AlphaValues[Count + 3] := 0; end; procedure MakeAlphaEvenOddLCD(Coverage: PSingleArray; AlphaValues: SysUtils.PByteArray; Count: Integer; Color: TColor32); var I: Integer; M, V: Cardinal; Last: TFloat; begin M := Color shr 24 * 86; // 86 = 258 / 3 Last := Infinity; V := 0; AlphaValues[0] := 0; AlphaValues[1] := 0; for I := 0 to Count - 1 do begin if PInteger(@Last)^ <> PInteger(@Coverage[I])^ then begin Last := Coverage[I]; V := Abs(Round(Coverage[I] * $10000)); V := V and $01ffff; if V >= $10000 then V := V xor $1ffff; V := V * M shr 24; end; Inc(AlphaValues[I], V); {$IFDEF USEGR32GAMMA} AlphaValues[I] := GAMMA_TABLE[AlphaValues[I]]; {$ENDIF} Inc(AlphaValues[I + 1], V); AlphaValues[I + 2] := V; end; AlphaValues[Count + 2] := 0; AlphaValues[Count + 3] := 0; end; procedure MakeAlphaNonZeroLCD2(Coverage: PSingleArray; AlphaValues: SysUtils.PByteArray; Count: Integer; Color: TColor32); var I: Integer; begin MakeAlphaNonZeroLCD(Coverage, AlphaValues, Count, Color); AlphaValues[Count + 2] := (AlphaValues[Count] + AlphaValues[Count + 1]) div 3; AlphaValues[Count + 3] := AlphaValues[Count + 1] div 3; for I := Count + 1 downto 2 do begin AlphaValues[I] := (AlphaValues[I] + AlphaValues[I - 1] + AlphaValues[I - 2]) div 3; end; AlphaValues[1] := (AlphaValues[0] + AlphaValues[1]) div 3; AlphaValues[0] := AlphaValues[0] div 3; end; procedure MakeAlphaEvenOddLCD2(Coverage: PSingleArray; AlphaValues: SysUtils.PByteArray; Count: Integer; Color: TColor32); var I: Integer; begin MakeAlphaEvenOddLCD(Coverage, AlphaValues, Count, Color); AlphaValues[Count + 2] := (AlphaValues[Count] + AlphaValues[Count + 1]) div 3; AlphaValues[Count + 3] := AlphaValues[Count + 1] div 3; for I := Count + 1 downto 2 do begin AlphaValues[I] := (AlphaValues[I] + AlphaValues[I - 1] + AlphaValues[I - 2]) div 3; end; AlphaValues[1] := (AlphaValues[0] + AlphaValues[1]) div 3; AlphaValues[0] := AlphaValues[0] div 3; end; procedure CombineLineLCD(Weights: PRGBTripleArray; Dst: PColor32Array; Color: TColor32; Count: Integer); var I: Integer; {$IFDEF TEST_BLENDMEMRGB128SSE4} Weights64: UInt64; {$ENDIF} begin I := 0; while Count <> 0 do {$IFDEF TEST_BLENDMEMRGB128SSE4} if (Count shr 1) = 0 then {$ENDIF} begin if PColor32(@Weights[I])^ = $FFFFFFFF then Dst[I] := Color else BlendMemRGB(Color, Dst[I], PColor32(@Weights[I])^); Dec(Count); Inc(I); end {$IFDEF TEST_BLENDMEMRGB128SSE4} else begin Weights64 := (UInt64(PColor32(@Weights[I + 1])^) shl 32) or PColor32(@Weights[I])^; if Weights64 = $FFFFFFFFFFFFFFFF then begin Dst[I] := Color; Dst[I + 1] := Color; end else BlendMemRGB128(Color, Dst[I], Weights64); Dec(Count, 2); Inc(I, 2); end {$ENDIF}; EMMS; end; { TCustomPolygonFiller } procedure TCustomPolygonFiller.BeginRendering; begin // implemented by descendants end; procedure TCustomPolygonFiller.EndRendering; begin // implemented by descendants end; { TCallbackPolygonFiller } function TCallbackPolygonFiller.GetFillLine: TFillLineEvent; begin Result := FFillLineEvent; end; { TInvertPolygonFiller } procedure TInvertPolygonFiller.FillLineBlend(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; BlendMemEx: TBlendMemEx; begin BlendMemEx := BLEND_MEM_EX[cmBlend]^; for X := DstX to DstX + Length - 1 do begin BlendMemEx(InvertColor(Dst^), Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; function TInvertPolygonFiller.GetFillLine: TFillLineEvent; begin Result := FillLineBlend; end; { TBitmapPolygonFiller } procedure TBitmapPolygonFiller.FillLineOpaque(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var PatternX, PatternY, X: Integer; OpaqueAlpha: TColor32; Src: PColor32; BlendMemEx: TBlendMemEx; begin PatternX := (DstX - OffsetX) mod FPattern.Width; if PatternX < 0 then PatternX := (FPattern.Width + PatternX) mod FPattern.Width; PatternY := (DstY - OffsetY) mod FPattern.Height; if PatternY < 0 then PatternY := (FPattern.Height + PatternY) mod FPattern.Height; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; if Assigned(AlphaValues) then begin OpaqueAlpha := TColor32($FF shl 24); BlendMemEx := BLEND_MEM_EX[FPattern.CombineMode]^; for X := DstX to DstX + Length - 1 do begin BlendMemEx(Src^ and $00FFFFFF or OpaqueAlpha, Dst^, AlphaValues^); Inc(Dst); Inc(Src); Inc(PatternX); if PatternX >= FPattern.Width then begin PatternX := 0; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; end; Inc(AlphaValues); end end else for X := DstX to DstX + Length - 1 do begin Dst^ := Src^; Inc(Dst); Inc(Src); Inc(PatternX); if PatternX >= FPattern.Width then begin PatternX := 0; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; end; end; end; procedure TBitmapPolygonFiller.FillLineBlend(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var PatternX, PatternY, X: Integer; Src: PColor32; BlendMemEx: TBlendMemEx; BlendMem: TBlendMem; begin PatternX := (DstX - OffsetX) mod FPattern.Width; if PatternX < 0 then PatternX := (FPattern.Width + PatternX) mod FPattern.Width; PatternY := (DstY - OffsetY) mod FPattern.Height; if PatternY < 0 then PatternY := (FPattern.Height + PatternY) mod FPattern.Height; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; if Assigned(AlphaValues) then begin BlendMemEx := BLEND_MEM_EX[FPattern.CombineMode]^; for X := DstX to DstX + Length - 1 do begin BlendMemEx(Src^, Dst^, AlphaValues^); Inc(Dst); Inc(Src); Inc(PatternX); if PatternX >= FPattern.Width then begin PatternX := 0; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; end; Inc(AlphaValues); end end else begin BlendMem := BLEND_MEM[FPattern.CombineMode]^; for X := DstX to DstX + Length - 1 do begin BlendMem(Src^, Dst^); Inc(Dst); Inc(Src); Inc(PatternX); if PatternX >= FPattern.Width then begin PatternX := 0; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; end; end; end; end; procedure TBitmapPolygonFiller.FillLineBlendMasterAlpha(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var PatternX, PatternY, X: Integer; Src: PColor32; BlendMemEx: TBlendMemEx; begin PatternX := (DstX - OffsetX) mod FPattern.Width; if PatternX < 0 then PatternX := (FPattern.Width + PatternX) mod FPattern.Width; PatternY := (DstY - OffsetY) mod FPattern.Height; if PatternY < 0 then PatternY := (FPattern.Height + PatternY) mod FPattern.Height; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; BlendMemEx := BLEND_MEM_EX[FPattern.CombineMode]^; if Assigned(AlphaValues) then for X := DstX to DstX + Length - 1 do begin BlendMemEx(Src^, Dst^, Div255(AlphaValues^ * FPattern.MasterAlpha)); Inc(Dst); Inc(Src); Inc(PatternX); if PatternX >= FPattern.Width then begin PatternX := 0; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; end; Inc(AlphaValues); end else for X := DstX to DstX + Length - 1 do begin BlendMemEx(Src^, Dst^, FPattern.MasterAlpha); Inc(Dst); Inc(Src); Inc(PatternX); if PatternX >= FPattern.Width then begin PatternX := 0; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; end; end; end; procedure TBitmapPolygonFiller.FillLineCustomCombine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var PatternX, PatternY, X: Integer; Src: PColor32; begin PatternX := (DstX - OffsetX) mod FPattern.Width; if PatternX < 0 then PatternX := (FPattern.Width + PatternX) mod FPattern.Width; PatternY := (DstY - OffsetY) mod FPattern.Height; if PatternY < 0 then PatternY := (FPattern.Height + PatternY) mod FPattern.Height; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; if Assigned(AlphaValues) then for X := DstX to DstX + Length - 1 do begin FPattern.OnPixelCombine(Src^, Dst^, Div255(AlphaValues^ * FPattern.MasterAlpha)); Inc(Dst); Inc(Src); Inc(PatternX); if PatternX >= FPattern.Width then begin PatternX := 0; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; end; Inc(AlphaValues); end else for X := DstX to DstX + Length - 1 do begin FPattern.OnPixelCombine(Src^, Dst^, FPattern.MasterAlpha); Inc(Dst); Inc(Src); Inc(PatternX); if PatternX >= FPattern.Width then begin PatternX := 0; Src := @FPattern.Bits[PatternX + PatternY * FPattern.Width]; end; end; end; function TBitmapPolygonFiller.GetFillLine: TFillLineEvent; begin if not Assigned(FPattern) then begin Result := nil; end else if FPattern.DrawMode = dmOpaque then Result := FillLineOpaque else if FPattern.DrawMode = dmBlend then begin if FPattern.MasterAlpha = 255 then Result := FillLineBlend else Result := FillLineBlendMasterAlpha; end else if (FPattern.DrawMode = dmCustom) and Assigned(FPattern.OnPixelCombine) then begin Result := FillLineCustomCombine; end else Result := nil; end; { TSamplerFiller } constructor TSamplerFiller.Create(Sampler: TCustomSampler = nil); begin inherited Create; FSampler := Sampler; SamplerChanged; end; procedure TSamplerFiller.EndRendering; begin if Assigned(FSampler) then FSampler.FinalizeSampling else raise Exception.Create(RCStrNoSamplerSpecified); end; procedure TSamplerFiller.SampleLineOpaque(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); var X: Integer; BlendMemEx: TBlendMemEx; begin BlendMemEx := BLEND_MEM_EX[cmBlend]^; for X := DstX to DstX + Length - 1 do begin BlendMemEx(FGetSample(X, DstY) and $00FFFFFF or $FF000000, Dst^, AlphaValues^); EMMS; Inc(Dst); Inc(AlphaValues); end; end; procedure TSamplerFiller.SamplerChanged; begin if Assigned(FSampler) then FGetSample := FSampler.GetSampleInt; end; procedure TSamplerFiller.BeginRendering; begin if Assigned(FSampler) then FSampler.PrepareSampling else raise Exception.Create(RCStrNoSamplerSpecified); end; function TSamplerFiller.GetFillLine: TFillLineEvent; begin Result := SampleLineOpaque; end; procedure TSamplerFiller.SetSampler(const Value: TCustomSampler); begin if FSampler <> Value then begin FSampler := Value; SamplerChanged; end; end; { TCustomPolygonRenderer } procedure TCustomPolygonRenderer.PolygonFS( const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation); begin PolyPolygonFS(PolyPolygon(Points), ClipRect, Transformation); end; procedure TCustomPolygonRenderer.PolygonFS( const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect); begin PolyPolygonFS(PolyPolygon(Points), ClipRect); end; procedure TCustomPolygonRenderer.PolyPolygonFS( const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); begin // implemented by descendants end; procedure TCustomPolygonRenderer.PolyPolygonFS( const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; Transformation: TTransformation); var APoints: TArrayOfArrayOfFloatPoint; begin if Assigned(Transformation) then APoints := TransformPolyPolygon(Points, Transformation) else APoints := Points; PolyPolygonFS(APoints, ClipRect); end; { TPolygonRenderer32 } constructor TPolygonRenderer32.Create(Bitmap: TBitmap32; Fillmode: TPolyFillMode); begin inherited Create; FBitmap := Bitmap; FFillMode := Fillmode; end; procedure TPolygonRenderer32.PolygonFS(const Points: TArrayOfFloatPoint); begin PolyPolygonFS(PolyPolygon(Points), FloatRect(FBitmap.ClipRect)); end; procedure TPolygonRenderer32.PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint); begin PolyPolygonFS(Points, FloatRect(FBitmap.ClipRect)); end; procedure TPolygonRenderer32.SetBitmap(const Value: TBitmap32); begin if FBitmap <> Value then begin FBitmap := Value; Changed; end; end; procedure TPolygonRenderer32.SetColor(const Value: TColor32); begin if FColor <> Value then begin FColor := Value; Changed; end; end; procedure TPolygonRenderer32.SetFiller(const Value: TCustomPolygonFiller); begin if FFiller <> Value then begin FFiller := Value; Changed; end; end; procedure TPolygonRenderer32.SetFillMode(const Value: TPolyFillMode); begin if FFillMode <> Value then begin FFillMode := Value; Changed; end; end; { TPolygonRenderer32VPR } {$IFDEF USESTACKALLOC} {$W+} {$ENDIF} procedure TPolygonRenderer32VPR.FillSpan(const Span: TValueSpan; DstY: Integer); var AlphaValues: PColor32Array; Count: Integer; begin Count := Span.X2 - Span.X1 + 1; {$IFDEF USESTACKALLOC} AlphaValues := StackAlloc(Count * SizeOf(TColor32)); {$ELSE} GetMem(AlphaValues, Count * SizeOf(TColor32)); {$ENDIF} FFillProc(Span.Values, AlphaValues, Count, FColor); FFiller.FillLine(@Bitmap.ScanLine[DstY][Span.X1], Span.X1, DstY, Count, PColor32(AlphaValues)); EMMS; {$IFDEF USESTACKALLOC} StackFree(AlphaValues); {$ELSE} FreeMem(AlphaValues); {$ENDIF} end; {$IFDEF USESTACKALLOC} {$W-} {$ENDIF} function TPolygonRenderer32VPR.GetRenderSpan: TRenderSpanEvent; begin if Assigned(FFiller) then Result := FillSpan else Result := RenderSpan; end; procedure TPolygonRenderer32VPR.PolyPolygonFS( const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); {$IFDEF CHANGENOTIFICATIONS} var I: Integer; {$ENDIF} begin UpdateFillProcs; if Assigned(FFiller) then begin FFiller.BeginRendering; RenderPolyPolygon(Points, ClipRect, GetRenderSpan()); FFiller.EndRendering; end else RenderPolyPolygon(Points, ClipRect, GetRenderSpan()); {$IFDEF CHANGENOTIFICATIONS} if TBitmap32Access(Bitmap).UpdateCount = 0 then for I := 0 to High(Points) do if Length(Points[I]) > 0 then Bitmap.Changed(MakeRect(PolygonBounds(Points[I]))); {$ENDIF} end; {$W+} procedure TPolygonRenderer32VPR.RenderSpan(const Span: TValueSpan; DstY: Integer); var AlphaValues: PColor32Array; Count: Integer; begin Count := Span.X2 - Span.X1 + 1; {$IFDEF USESTACKALLOC} AlphaValues := StackAlloc(Count * SizeOf(TColor32)); {$ELSE} GetMem(AlphaValues, Count * SizeOf(TColor32)); {$ENDIF} FFillProc(Span.Values, AlphaValues, Count, FColor); if Bitmap.CombineMode = cmMerge then MergeLine(@AlphaValues[0], @Bitmap.ScanLine[DstY][Span.X1], Count) else BlendLine(@AlphaValues[0], @Bitmap.ScanLine[DstY][Span.X1], Count); EMMS; {$IFDEF USESTACKALLOC} StackFree(AlphaValues); {$ELSE} FreeMem(AlphaValues); {$ENDIF} end; {$W-} procedure TPolygonRenderer32VPR.UpdateFillProcs; const FillProcs: array [Boolean, TPolyFillMode] of TFillProc = ( (MakeAlphaEvenOddUP, MakeAlphaNonZeroUP), (MakeAlphaEvenOddUPF, MakeAlphaNonZeroUPF) ); begin FFillProc := FillProcs[Assigned(FFiller), FillMode]; end; { TPolygonRenderer32LCD } procedure TPolygonRenderer32LCD.PolyPolygonFS( const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); var R: TFloatRect; APoints: TArrayOfArrayOfFloatPoint; {$IFDEF CHANGENOTIFICATIONS} I: Integer; {$ENDIF} begin APoints := ScalePolyPolygon(Points, 3, 1); R.Top := ClipRect.Top; R.Bottom := ClipRect.Bottom; R.Left := ClipRect.Left * 3; R.Right := ClipRect.Right * 3; RenderPolyPolygon(APoints, R, RenderSpan); {$IFDEF CHANGENOTIFICATIONS} if TBitmap32Access(Bitmap).UpdateCount = 0 then for I := 0 to High(Points) do if length(Points[I]) > 0 then Bitmap.Changed(MakeRect(PolygonBounds(Points[I]))); {$ENDIF} end; {$W+} procedure TPolygonRenderer32LCD.RenderSpan(const Span: TValueSpan; DstY: Integer); const PADDING = 5; var AlphaValues: SysUtils.PByteArray; Count: Integer; X1, Offset: Integer; const MakeAlpha: array [TPolyFillMode] of TMakeAlphaProcLCD = (MakeAlphaEvenOddLCD, MakeAlphaNonZeroLCD); begin Count := Span.X2 - Span.X1 + 1; X1 := DivMod(Span.X1, 3, Offset); // Left Padding + Right Padding + Filter Width = 2 + 2 + 2 = 6 {$IFDEF USESTACKALLOC} AlphaValues := StackAlloc((Count + 6 + PADDING) * SizeOf(Byte)); {$ELSE} GetMem(AlphaValues, (Count + 6 + PADDING) * SizeOf(Byte)); {$ENDIF} AlphaValues[0] := 0; AlphaValues[1] := 0; if (X1 > 0) then begin Dec(X1); Inc(Offset, 3); AlphaValues[2] := 0; AlphaValues[3] := 0; AlphaValues[4] := 0; end; MakeAlpha[FFillMode](Span.Values, PByteArray(@AlphaValues[PADDING]), Count, FColor); CombineLineLCD(@AlphaValues[PADDING - Offset], PColor32Array(@Bitmap.ScanLine[DstY][X1]), FColor, (Count + Offset + 2) div 3); {$IFDEF USESTACKALLOC} StackFree(AlphaValues); {$ELSE} FreeMem(AlphaValues); {$ENDIF} end; {$W-} { TPolygonRenderer32LCD2 } {$W+} procedure TPolygonRenderer32LCD2.RenderSpan(const Span: TValueSpan; DstY: Integer); const PADDING = 5; var AlphaValues: SysUtils.PByteArray; Count: Integer; X1, Offset: Integer; const MakeAlpha: array [TPolyFillMode] of TMakeAlphaProcLCD = (MakeAlphaEvenOddLCD2, MakeAlphaNonZeroLCD2); begin Count := Span.X2 - Span.X1 + 1; X1 := DivMod(Span.X1, 3, Offset); // Left Padding + Right Padding + Filter Width = 2 + 2 + 2 = 6 {$IFDEF USESTACKALLOC} AlphaValues := StackAlloc((Count + 6 + PADDING) * SizeOf(Byte)); {$ELSE} GetMem(AlphaValues, (Count + 6 + PADDING) * SizeOf(Byte)); {$ENDIF} AlphaValues[0] := 0; AlphaValues[1] := 0; if (X1 > 0) then begin Dec(X1); Inc(Offset, 3); AlphaValues[2] := 0; AlphaValues[3] := 0; AlphaValues[4] := 0; end; Dec(Offset, 1); MakeAlpha[FFillMode](Span.Values, PByteArray(@AlphaValues[PADDING]), Count, FColor); Inc(Count); CombineLineLCD(@AlphaValues[PADDING - Offset], PColor32Array(@Bitmap.ScanLine[DstY][X1]), FColor, (Count + Offset + 2) div 3); {$IFDEF USESTACKALLOC} StackFree(AlphaValues); {$ELSE} FreeMem(AlphaValues); {$ENDIF} end; {$W-} initialization RegisterPolygonRenderer(TPolygonRenderer32VPR); RegisterPolygonRenderer(TPolygonRenderer32LCD); RegisterPolygonRenderer(TPolygonRenderer32LCD2); finalization PolygonRendererList.Free; end. |
Added src/graphics32/GR32_PolygonsAggLite.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 | unit GR32_PolygonsAggLite; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is a mixture of AggLite and the other polygon renderers of * Graphics32 * * The Initial Developer is * Christian-W. Budde <Christian@savioursofsoul.de> * * Portions created by the Initial Developer are Copyright (C) 2008-2012 * the Initial Developer. All Rights Reserved. * * AggLite is based on Anti-Grain Geometry (Version 2.0) * Copyright (C) 2002-2004 Maxim Shemanarev (McSeem) * * Permission to copy, use, modify, sell and distribute this software * is granted provided this copyright notice appears in all copies. * This software is provided "as is" without express or implied * warranty, and with no claim as to its suitability for any purpose. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Types, GR32, GR32_Polygons, GR32_Transforms; type TPolygonRenderer32AggLite = class(TPolygonRenderer32) protected procedure Render(CellsPtr: Pointer; MinX, MaxX: Integer); public procedure PolygonFS(const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect); override; procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); override; end; procedure PolyPolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; procedure PolyPolylineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; procedure PolyPolylineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; procedure PolylineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; procedure PolylineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; procedure DashLineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Color: TColor32; Closed: Boolean = False; Width: TFloat = 1.0); overload; procedure DashLineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; FillColor, StrokeColor: TColor32; Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); overload; procedure DashLineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; Closed: Boolean = False; Width: TFloat = 1.0); overload; procedure DashLineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; StrokeColor: TColor32; Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); overload; implementation uses Math, GR32_Blend, GR32_LowLevel, GR32_System, GR32_Bindings, GR32_VectorUtils; procedure PolyPolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32AggLite; begin Renderer := TPolygonRenderer32AggLite.Create; try Renderer.Bitmap := Bitmap; Renderer.Color := Color; Renderer.FillMode := FillMode; Renderer.PolyPolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32AggLite; begin Renderer := TPolygonRenderer32AggLite.Create; try Renderer.Bitmap := Bitmap; Renderer.Color := Color; Renderer.FillMode := FillMode; Renderer.PolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32AggLite; begin if not Assigned(Filler) then Exit; Renderer := TPolygonRenderer32AggLite.Create; try Renderer.Bitmap := Bitmap; Renderer.Filler := Filler; Renderer.FillMode := FillMode; Renderer.PolyPolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32AggLite; begin if not Assigned(Filler) then Exit; Renderer := TPolygonRenderer32AggLite.Create; try Renderer.Bitmap := Bitmap; Renderer.Filler := Filler; Renderer.FillMode := FillMode; Renderer.PolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32AggLite; IntersectedClipRect: TRect; begin Renderer := TPolygonRenderer32AggLite.Create; try Renderer.Bitmap := Bitmap; Renderer.Color := Color; Renderer.FillMode := FillMode; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolyPolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32AggLite; IntersectedClipRect: TRect; begin Renderer := TPolygonRenderer32AggLite.Create; try Renderer.Bitmap := Bitmap; Renderer.Color := Color; Renderer.FillMode := FillMode; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32AggLite; IntersectedClipRect: TRect; begin if not Assigned(Filler) then Exit; Renderer := TPolygonRenderer32AggLite.Create; try Renderer.Bitmap := Bitmap; Renderer.Filler := Filler; Renderer.FillMode := FillMode; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolyPolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolygonFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); var Renderer: TPolygonRenderer32AggLite; IntersectedClipRect: TRect; begin if not Assigned(Filler) then Exit; Renderer := TPolygonRenderer32AggLite.Create; try Renderer.Bitmap := Bitmap; Renderer.Filler := Filler; Renderer.FillMode := FillMode; GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); Renderer.PolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); finally Renderer.Free; end; end; procedure PolyPolylineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Color: TColor32; Closed: Boolean; StrokeWidth: TFloat; JoinStyle: TJoinStyle; EndStyle: TEndStyle; MiterLimit: TFloat; Transformation: TTransformation); var Dst: TArrayOfArrayOfFloatPoint; begin Dst := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit); PolyPolygonFS_AggLite(Bitmap, Dst, Color, pfWinding, Transformation); end; procedure PolyPolylineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); var Dst: TArrayOfArrayOfFloatPoint; begin Dst := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit); PolyPolygonFS(Bitmap, Dst, Filler, pfWinding, Transformation); end; procedure PolylineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Color: TColor32; Closed: Boolean; StrokeWidth: TFloat; JoinStyle: TJoinStyle; EndStyle: TEndStyle; MiterLimit: TFloat; Transformation: TTransformation); begin PolyPolylineFS_AggLite(Bitmap, PolyPolygon(Points), Color, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit, Transformation); end; procedure PolylineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); begin PolyPolylineFS_AggLite(Bitmap, PolyPolygon(Points), Filler, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit, Transformation); end; procedure DashLineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Color: TColor32; Closed: Boolean = False; Width: TFloat = 1.0); var MultiPoly: TArrayOfArrayOfFloatPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); PolyPolylineFS_AggLite(Bitmap, MultiPoly, Color, False, Width); end; procedure DashLineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; FillColor, StrokeColor: TColor32; Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); var MultiPoly: TArrayOfArrayOfFloatPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); MultiPoly := BuildPolyPolyLine(MultiPoly, False, Width); PolyPolygonFS_AggLite(Bitmap, MultiPoly, FillColor); PolyPolylineFS_AggLite(Bitmap, MultiPoly, StrokeColor, True, StrokeWidth); end; procedure DashLineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; Closed: Boolean = False; Width: TFloat = 1.0); var MultiPoly: TArrayOfArrayOfFloatPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); PolyPolylineFS_AggLite(Bitmap, MultiPoly, Filler, False, Width); end; procedure DashLineFS_AggLite(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; StrokeColor: TColor32; Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); var MultiPoly: TArrayOfArrayOfFloatPoint; begin MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); MultiPoly := BuildPolyPolyLine(MultiPoly, False, Width); PolyPolygonFS_AggLite(Bitmap, MultiPoly, Filler); PolyPolylineFS_AggLite(Bitmap, MultiPoly, StrokeColor, True, StrokeWidth); end; const CPolyBaseShift = 8; CPolyBaseSize = 1 shl CPolyBaseShift; CPolyBaseMask = CPolyBaseSize - 1; CCellBlockShift = 12; CCellBlockSize = 1 shl CCellBlockShift; CCellBlockMask = CCellBlockSize - 1; CCellBlockPool = 256; CCellBlockLimit = 1024; type PPColor32 = ^PColor32; TPointWord = record case Byte of 0: (X, Y: SmallInt); 1: (PackedCoord: Integer); end; TCell = packed record Pnt: TPointWord; PackedCoord: Integer; Cover: Integer; Area: Integer; end; PCell = ^TCell; PPCell = ^PCell; TScanLine = class(TObject) private FCounts: PWord; FCovers: PColor32Array; FCurCount: PWord; FCurStartPtr: PPColor32; FLastX: Integer; FLastY: Integer; FMaxLen: Cardinal; FMinX: Integer; FNumSpans: Cardinal; FStartPtrs: PPColor32; public constructor Create(MinX, MaxX: Integer); destructor Destroy; override; procedure AddCell(X, Y: Integer; Cover: Cardinal); procedure AddSpan(X, Y: Integer; Len, Cover: Cardinal); function IsReady(Y: Integer): Integer; procedure ResetSpans; property BaseX: Integer read FMinX; property Y: Integer read FLastY; property NumSpans: Cardinal read FNumSpans; property CountsPtr: PWord read FCounts; property CoversPtr: PColor32Array read FCovers; property StartPtrs: PPColor32 read FStartPtrs; end; TOutlineFlag = (ofNotClosed, ofSortRequired); TOutlineFlags = set of TOutlineFlag; TOutline = class(TObject) private FCells: PPCell; FClose: TPoint; FCurBlock: Cardinal; FCurCell: TCell; FCurCellPtr: PCell; FCur: TPoint; FFlags: TOutlineFlags; FMaxBlocks: Cardinal; FMax: TPoint; FMin: TPoint; FNumBlocks: Cardinal; FNumCells: Cardinal; FSortedCells: PPCell; FSortedSize: Cardinal; procedure AddCurCell; procedure AllocateBlock; function GetCells: PPCell; procedure RenderLine(X1, Y1, X2, Y2: Integer); procedure RenderScanLine(EY, X1, Y1, X2, Y2: Integer); procedure SetCurCell(X, Y: Integer); procedure SortCells; procedure InternalReset; public constructor Create; destructor Destroy; override; procedure LineTo(X, Y: Integer); procedure MoveTo(X, Y: Integer); procedure Reset; property Cells: PPCell read GetCells; property MaxX: Integer read FMax.X; property MaxY: Integer read FMax.Y; property MinX: Integer read FMin.X; property MinY: Integer read FMin.Y; property NumCells: Cardinal read FNumCells; end; function Fixed8(C: TFloat): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result := Trunc(C * CPolyBaseSize); end; { TCell } procedure SetCell(var Cell: TCell; CX, CY: Integer); {$IFDEF USEINLINING} inline; {$ENDIF} begin with Cell do begin Pnt.X := SmallInt(CX); Pnt.Y := SmallInt(CY); PackedCoord := (CY shl 16) + CX; Cover := 0; Area := 0; end; end; procedure PartSort(var A, B: PPCell; const Stop: PCell); {$IFDEF PUREPASCAL} {$IFDEF USEINLINING} inline; {$ENDIF} procedure SwapCells(A, B: PPCell); {$IFDEF USEINLINING} inline; {$ENDIF} var Temp: PCell; begin Temp := A^; A^ := B^; B^ := Temp; end; begin while True do begin repeat Inc(A) until (A^^.PackedCoord >= Stop^.PackedCoord); repeat Dec(B) until (B^^.PackedCoord <= Stop^.PackedCoord); {$IFDEF FPC} if PtrInt(A) > PtrInt(B) then Break; {$ELSE} {$IFDEF HAS_NATIVEINT} if NativeInt(A) > NativeInt(B) then Break; {$ELSE} if Integer(A) > Integer(B) then Break; {$ENDIF} {$ENDIF} SwapCells(A, B); end; {$ELSE} asm {$IFDEF CPUX86} PUSH EBX PUSH EDI PUSH ESI PUSH EBP MOV ECX, [ECX + 4] @0: MOV EDI, [EAX] @1: ADD EDI, $04 MOV EBX, [EDI] CMP ECX, [EBX + 4] JG @1 MOV [EAX], EDI MOV EDI, [EDX] @2: SUB EDI, $04 MOV EBX, [EDI] CMP ECX, [EBX + 4] JL @2 MOV [EDX], EDI CMP EDI, [EAX] JLE @3 MOV EBX, [EAX] MOV ESI, [EBX] MOV EBP, [EDI] MOV [EDI], ESI MOV [EBX], EBP JMP @0 @3: POP EBP POP ESI POP EDI POP EBX {$ENDIF} {$IFDEF CPUX64} MOV R8D, [R8 + 4] @0: MOV R9, [RCX] @1: ADD R9, $08 MOV RAX, [R9] CMP R8D, [RAX + 4] JG @1 MOV [RCX], R9 MOV R9, [RDX] @2: SUB R9, $08 MOV RAX, [R9] CMP R8D, [RAX + 4] JL @2 MOV [RDX], R9 CMP R9, [RCX] JLE @3 MOV RAX, [RCX] MOV R10, [RAX] MOV R11, [R9] MOV [RAX], R11 MOV [R9], R10 JMP @0 @3: {$ENDIF} {$ENDIF} end; procedure QSortCells(Start: PPCell; Num: Cardinal); const QSortThreshold = 9; var Stack: array [0 .. 79] of PPCell; Top: ^PPCell; Limit, Base, I, J, Pivot: PPCell; Len: Integer; procedure CheckCells(var A, B: PCell); {$IFDEF USEINLINING} inline; {$ENDIF} var Temp: PCell; begin if A^.PackedCoord < B^.PackedCoord then begin Temp := A; A := B; B := Temp; end; end; procedure SwapCells(A, B: PPCell); {$IFDEF USEINLINING} inline; {$ENDIF} var Temp: PCell; begin Temp := A^; A^ := B^; B^ := Temp; end; function LessThan(A, B: PPCell): Boolean; {$IFDEF USEINLINING} inline; {$ENDIF} begin Result := A^^.PackedCoord < B^^.PackedCoord; end; begin {$IFDEF FPC} Limit := PPCell(PtrInt(Start) + Num * SizeOf(PCell)); {$ELSE} {$IFDEF HAS_NATIVEINT} Limit := PPCell(NativeUInt(Start) + Num * SizeOf(PCell)); {$ELSE} Limit := PPCell(Cardinal(Start) + Num * SizeOf(PCell)); {$ENDIF} {$ENDIF} Base := Start; Top := @Stack[0]; while True do begin {$IFDEF FPC} Len := (PtrInt(Limit) - PtrInt(Base)) div SizeOf(PCell); {$ELSE} {$IFDEF HAS_NATIVEINT} Len := (NativeInt(Limit) - NativeInt(Base)) div SizeOf(PCell); {$ELSE} Len := (Integer(Limit) - Integer(Base)) div SizeOf(PCell); {$ENDIF} {$ENDIF} if Len > QSortThreshold then begin // we use Base + (Len div 2) as the pivot Pivot := Base; Inc(Pivot, Len div 2); SwapCells(Base, Pivot); I := Base; Inc(I); J := Limit; Dec(J); // now ensure that I^ <= Base^ <= J^ CheckCells(J^, I^); CheckCells(Base^, I^); CheckCells(J^, Base^); PartSort(I, J, Base^); SwapCells(Base, J); // now, push the largest sub-array {$IFDEF FPC} if PtrInt(J) - PtrInt(Base) > PtrInt(Limit) - PtrInt(I) then {$ELSE} {$IFDEF HAS_NATIVEINT} if NativeInt(J) - NativeInt(Base) > NativeInt(Limit) - NativeInt(I) then {$ELSE} if Integer(J) - Integer(Base) > Integer(Limit) - Integer(I) then {$ENDIF} {$ENDIF} begin Top^ := Base; Inc(Top); Top^ := J; Base := I; end else begin Top^ := I; Inc(Top); Top^ := Limit; Limit := J; end; Inc(Top); end else begin // the sub-array is small, perform insertion sort J := Base; I := J; Inc(I); {$IFDEF FPC} while PtrInt(I) < PtrInt(Limit) do {$ELSE} {$IFDEF HAS_NATIVEINT} while NativeInt(I) < NativeInt(Limit) do {$ELSE} while Integer(I) < Integer(Limit) do {$ENDIF} {$ENDIF} begin {$IFDEF FPC} while LessThan(PPCell(PtrInt(J) + SizeOf(PCell)), J) do begin SwapCells(PPCell(PtrInt(J) + SizeOf(PCell)), J); {$ELSE} {$IFDEF HAS_NATIVEINT} while LessThan(PPCell(NativeUInt(J) + SizeOf(PCell)), J) do begin SwapCells(PPCell(NativeUInt(J) + SizeOf(PCell)), J); {$ELSE} while LessThan(PPCell(Cardinal(J) + SizeOf(PCell)), J) do begin SwapCells(PPCell(Cardinal(J) + SizeOf(PCell)), J); {$ENDIF} {$ENDIF} if J = Base then Break; Dec(J); end; J := I; Inc(I); end; {$IFDEF FPC} if PtrInt(Top) > PtrInt(@Stack[0]) then {$ELSE} {$IFDEF HAS_NATIVEINT} if NativeInt(Top) > NativeInt(@Stack[0]) then {$ELSE} if Integer(Top) > Integer(@Stack[0]) then {$ENDIF} {$ENDIF} begin Dec(Top, 2); Base := Top^; Limit := PPCell(Pointer(NativeInt(Top) + SizeOf(PPCell))^); end else Break; end; end; end; var FillSpan: procedure (Ptr: PColor32Array; Covers: PColor32; Count: Cardinal; const C: TColor32); procedure FillSpan_Pas(Ptr: PColor32Array; Covers: PColor32; Count: Cardinal; const C: TColor32); begin repeat BlendMemEx(C, PColor32(Ptr)^, Covers^); Inc(Covers); Inc(Ptr); Dec(Count); until Count = 0; end; procedure FillSpan_ASM(Ptr: PColor32Array; Covers: PColor32; Count: Cardinal; const C: TColor32); asm {$IFDEF CPUX86} PUSH EBX PUSH ESI PUSH EDI LEA ESI, EDX + 4 * ECX // ESI = Covers LEA EDI, EAX + 4 * ECX // EDI = P NEG ECX @LoopStart: MOVZX EBX, [ESI + 4 * ECX] MOVZX EAX, [EBP + $0B] // EAX = C.A IMUL EBX, EAX // EBX = Alpha MOVZX EAX, [EDI + 4 * ECX] MOVZX EDX, [EBP + $08] // EDX = C.R SUB EDX, EAX IMUL EDX, EBX SHL EAX, $10 ADD EDX, EAX SHR EDX, $10 MOV [EDI + 4 * ECX], DL // store to pointer MOVZX EAX, [EDI + 4 * ECX + 1] MOVZX EDX, [EBP + $09] // EDX = C.G SUB EDX, EAX IMUL EDX, EBX SHL EAX, $10 ADD EDX, EAX SHR EDX, $10 MOV [EDI + 4 * ECX + 1], DL // store to pointer MOVZX EAX, [EDI + 4 * ECX + 2] MOVZX EDX, [EBP + $0A] // EDX = C.B SUB EDX, EAX IMUL EDX, EBX SHL EAX, $10 ADD EDX, EAX SHR EDX, $10 MOV [EDI + 4 * ECX + 2], DL // store to pointer MOVZX EAX, [EDI + 4 * ECX + 3] MOVZX EDX, [EBP + $0B] // EDX = C.A SUB EDX, EAX IMUL EDX, EBX SHL EAX, $10 ADD EDX, EAX SHR EDX, $10 MOV [EDI + 4 * ECX + 3], DL // store to pointer ADD ECX, 1 JS @LoopStart POP EDI POP ESI POP EBX {$ENDIF} {$IFDEF CPUX64} LEA R10, RDX + 4 * R8 // R10 = Covers LEA R11, RCX + 4 * R8 // R11 = P NEG R8D @LoopStart: MOVZX R9D, [R10 + 4 * R8] MOVZX ECX, [EBP + $0B] // ECX = C.A IMUL R9D, ECX // R9D = Alpha MOVZX ECX, [R11 + 4 * R8] MOVZX EDX, [EBP + $08] // EDX = C.R SUB EDX, ECX IMUL EDX, R9D SHL ECX, $10 ADD EDX, ECX SHR EDX, $10 MOV [R11 + 4 * R8], DL // store to pointer MOVZX ECX, [R11 + 4 * R8 + 1] MOVZX EDX, [EBP + $09] // EDX = C.G SUB EDX, ECX IMUL EDX, R9D SHL ECX, $10 ADD EDX, ECX SHR EDX, $10 MOV [R11 + 4 * R8 + 1], DL // store to pointer MOVZX ECX, [R11 + 4 * R8 + 2] MOVZX EDX, [EBP + $0A] // EDX = C.B SUB EDX, ECX IMUL EDX, R9D SHL ECX, $10 ADD EDX, ECX SHR EDX, $10 MOV [R11 + 4 * R8 + 2], DL // store to pointer MOVZX ECX, [R11 + 4 * R8 + 3] MOVZX EDX, [EBP + $0B] // EDX = C.A SUB EDX, ECX IMUL EDX, R9D SHL ECX, $10 ADD EDX, ECX SHR EDX, $10 MOV [R11 + 4 * R8 + 3], DL // store to pointer ADD R8D, 1 JS @LoopStart {$ENDIF} end; {$IFNDEF OMIT_MMX} {$IFDEF TARGET_X86} procedure FillSpan_MMX(Ptr: PColor32Array; Covers: PColor32; Count: Cardinal; const C: TColor32); asm JCXZ @3 PUSH EBX PUSH ESI MOV ESI,EAX MOV EBX,C PXOR MM3,MM3 // MM3 = 0 MOVD MM1,EBX // MM1 = C (Foreground) PUNPCKLBW MM1,MM3 SHR EBX,24 JZ @2 INC EBX // 255:256 range bias @1: MOVD MM2,[ESI] // MM2 = Dest (Background) PUNPCKLBW MM2,MM3 MOV EAX,[EDX] // EAX = Alpha IMUL EAX,EBX SHR EAX,8 SHL EAX,4 ADD EAX,alpha_ptr MOVQ MM0,MM1 PSUBW MM0,MM2 PMULLW MM0,[EAX] PSLLW MM2,8 MOV EAX,bias_ptr PADDW MM2,[EAX] PADDW MM0,MM2 PSRLW MM0,8 PACKUSWB MM0,MM3 MOVD [ESI],MM0 ADD ESI,4 ADD EDX,4 DEC ECX JNZ @1 @2: POP ESI POP EBX @3: end; {$ENDIF} {$ENDIF} {$IFNDEF OMIT_SSE2} procedure FillSpan_SSE2(Ptr: PColor32Array; Covers: PColor32; Count: Cardinal; const C: TColor32); asm {$IFDEF TARGET_X86} JCXZ @5 PUSH EBX MOV EBX,C PXOR XMM7,XMM7 // XMM7 = 0 MOVD XMM1,EBX // XMM1 = C (Foreground) PUNPCKLBW XMM1,XMM7 SHR EBX,24 JZ @4 INC EBX // 255:256 range bias PUSH ESI MOV ESI,EAX @1: MOVQ XMM0,XMM1 MOVD XMM2,[ESI] // XMM2 = Dest (Background) PUNPCKLBW XMM2,XMM7 MOV EAX,[EDX] // EAX = Alpha IMUL EAX,EBX SHR EAX,8 JZ @3 CMP EAX,$FF JZ @2 SHL EAX,4 ADD EAX,alpha_ptr PSUBW XMM0,XMM2 PMULLW XMM0,[EAX] PSLLW XMM2,8 MOV EAX,bias_ptr PADDW XMM2,[EAX] PADDW XMM0,XMM2 PSRLW XMM0,8 @2: PACKUSWB XMM0,XMM7 MOVD [ESI],XMM0 @3: ADD ESI,4 ADD EDX,4 DEC ECX JNZ @1 POP ESI @4: POP EBX @5: {$ENDIF} {$IFDEF TARGET_X64} TEST R8D,R8D JZ @4 PXOR XMM7,XMM7 // XMM7 = 0 MOVD XMM1,R9D // XMM1 = C (Foreground) PUNPCKLBW XMM1,XMM7 SHR R9D,24 JZ @2 INC R9D // 255:256 range bias @1: MOVQ XMM0,XMM1 MOVD XMM2,[RCX] // XMM2 = Dest (Background) PUNPCKLBW XMM2,XMM7 MOV EAX,[RDX] // EAX = Alpha IMUL EAX,R9D SHR EAX,8 JZ @3 CMP EAX,$FF JZ @2 SHL EAX,4 ADD RAX,alpha_ptr PSUBW XMM0,XMM2 PMULLW XMM0,[RAX] PSLLW XMM2,8 MOV RAX,bias_ptr PADDW XMM2,[RAX] PADDW XMM0,XMM2 PSRLW XMM0,8 @2: PACKUSWB XMM0,XMM7 MOVD [RCX],XMM0 @3: ADD ECX,4 ADD EDX,4 DEC R8D JNZ @1 @4: {$ENDIF} end; {$ENDIF} function CalculateAlpha(FillMode: TPolyFillMode; Area: Integer): Cardinal; var Cover: Integer; const CAAShift = 8; CAANum = 1 shl CAAShift; CAAMask = CAANum - 1; CAA2Num = CAANum shl 1; CAA2Mask = CAA2Num - 1; begin Cover := SAR_9(Area); if Cover < 0 then Cover := -Cover; if FillMode = pfEvenOdd then begin Cover := Cover and CAA2Mask; if Cover > CAANum then Cover := CAA2Num - Cover; end; if Cover > CAAMask then Cover := CAAMask; Result := Cover; end; { TScanLine } constructor TScanLine.Create(MinX, MaxX: Integer); begin inherited Create; FMaxLen := MaxX - MinX + 2; GetMem(FCovers, FMaxLen * SizeOf(TColor32)); GetMem(FStartPtrs, FMaxLen * SizeOf(PColor32)); GetMem(FCounts, FMaxLen * SizeOf(Word)); FLastX := $7FFF; FLastY := $7FFF; FMinX := MinX; FCurCount := FCounts; FCurStartPtr := FStartPtrs; FNumSpans := 0; end; destructor TScanLine.Destroy; begin FreeMem(FCounts); FreeMem(FStartPtrs); FreeMem(FCovers); inherited Destroy; end; procedure TScanLine.AddCell(X, Y: Integer; Cover: Cardinal); begin Dec(X, FMinX); FCovers[X] := TColor32(Cover); if X = FLastX + 1 then Inc(FCurCount^) else begin Inc(FCurCount); FCurCount^ := 1; Inc(FCurStartPtr); FCurStartPtr^ := PColor32(@FCovers[X]); Inc(FNumSpans); end; FLastX := X; FLastY := Y; end; procedure TScanLine.AddSpan(X, Y: Integer; Len, Cover: Cardinal); begin Dec(X, FMinX); FillLongWord(FCovers[X], Len, Cover); if X = FLastX + 1 then Inc(FCurCount^, Word(Len)) else begin Inc(FCurCount); FCurCount^ := Word(Len); Inc(FCurStartPtr); FCurStartPtr^ := PColor32(@FCovers[X]); Inc(FNumSpans); end; FLastX := X + Integer(Len) - 1; FLastY := Y; end; function TScanLine.IsReady(Y: Integer): Integer; begin Result := Ord((FNumSpans <> 0) and ((Y xor FLastY) <> 0)); end; procedure TScanLine.ResetSpans; begin FLastX := $7FFF; FLastY := $7FFF; FCurCount := FCounts; FCurStartPtr := FStartPtrs; FNumSpans := 0; end; { TOutline } constructor TOutline.Create; begin inherited Create; FCurCellPtr := nil; FMin.X := $7FFFFFFF; FMin.Y := $7FFFFFFF; FMax.X := -$7FFFFFFF; FMax.Y := -$7FFFFFFF; FFlags := [ofSortRequired]; SetCell(FCurCell, $7FFF, $7FFF); end; destructor TOutline.Destroy; var Ptr: PPCell; begin FreeMem(FSortedCells); if FNumBlocks <> 0 then begin Ptr := PPCell(Cardinal(FCells) + (FNumBlocks - 1) * SizeOf(PCell)); while FNumBlocks <> 0 do begin FreeMem(Ptr^); Dec(Ptr); Dec(FNumBlocks); end; FreeMem(FCells); end; inherited Destroy; end; procedure TOutline.Reset; begin FNumCells := 0; FCurBlock := 0; InternalReset; end; procedure TOutline.InternalReset; begin FMin.X := $7FFFFFFF; FMin.Y := $7FFFFFFF; FMax.X := -$7FFFFFFF; FMax.Y := -$7FFFFFFF; FFlags := [ofSortRequired]; SetCell(FCurCell, $7FFF, $7FFF); end; procedure TOutline.AddCurCell; begin if FCurCell.Area or FCurCell.Cover <> 0 then begin if FNumCells and CCellBlockMask = 0 then begin if FNumBlocks >= CCellBlockLimit then Exit; AllocateBlock; end; FCurCellPtr^ := FCurCell; Inc(FCurCellPtr); Inc(FNumCells); end; end; procedure TOutline.AllocateBlock; var NewCells: PPCell; begin if FCurBlock >= FNumBlocks then begin if FNumBlocks >= FMaxBlocks then begin GetMem(NewCells, (FMaxBlocks + CCellBlockPool) * SizeOf(PCell)); if Assigned(FCells) then begin Move(FCells^, NewCells^, FMaxBlocks * SizeOf(PCell)); FreeMem(FCells); end; FCells := NewCells; Inc(FMaxBlocks, CCellBlockPool); end; GetMem(PPCell(Cardinal(FCells) + FNumBlocks * SizeOf(PCell))^, Cardinal(CCellBlockSize) * SizeOf(TCell)); Inc(FNumBlocks); end; FCurCellPtr := PPCell(Cardinal(FCells) + FCurBlock * SizeOf(PCell))^; Inc(FCurBlock); end; function TOutline.GetCells: PPCell; begin if ofNotClosed in FFlags then begin LineTo(FClose.X, FClose.Y); FFlags := FFlags - [ofNotClosed]; end; // Perform sort only the first time. if ofSortRequired in FFlags then begin AddCurCell; if FNumCells = 0 then begin Result := nil; Exit; end; SortCells; FFlags := FFlags - [ofSortRequired]; end; Result := FSortedCells; end; procedure TOutline.LineTo(X, Y: Integer); var C: Integer; begin if (ofSortRequired in FFlags) and (((FCur.X xor X) or (FCur.Y xor Y)) <> 0) then begin C := SAR_8(FCur.X); if C < FMin.X then FMin.X := C; Inc(C); if C > FMax.X then FMax.X := C; C := SAR_8(X); if C < FMin.X then FMin.X := C; Inc(C); if C > FMax.X then FMax.X := C; RenderLine(FCur.X, FCur.Y, X, Y); FCur.X := X; FCur.Y := Y; FFlags := FFlags + [ofNotClosed]; end; end; procedure TOutline.MoveTo(X, Y: Integer); begin if not (ofSortRequired in FFlags) then //-7468, -6124, -6124, -4836 Reset; if ofNotClosed in FFlags then LineTo(FClose.X, FClose.Y); SetCurCell(SAR_8(X), SAR_8(Y)); FCur.X := X; FClose.X := X; FCur.Y := Y; FClose.Y := Y; end; procedure TOutline.RenderLine(X1, Y1, X2, Y2: Integer); var EY1, EY2, FY1, FY2, Dx, Dy, XFrom, XTo, P, Rem, AMod, Lift: Integer; Delta, First, Incr, EX, TwoFx, Area: Integer; begin EY1 := SAR_8(Y1); EY2 := SAR_8(Y2); FY1 := Y1 and CPolyBaseMask; FY2 := Y2 and CPolyBaseMask; if EY1 < FMin.Y then FMin.Y := EY1; if EY1 >= FMax.Y then FMax.Y := EY1 + 1; if EY2 < FMin.Y then FMin.Y := EY2; if EY2 >= FMax.Y then FMax.Y := EY2 + 1; Dx := X2 - X1; Dy := Y2 - Y1; // everything is on a single scanline if EY1 = EY2 then begin RenderScanLine(EY1, X1, FY1, X2, FY2); Exit; end; // Vertical line - we have to calculate start and end cells, and then - // the common values of the area and coverage for all cells of the line. // We know exactly there's only one cell, so, we don't have to call // RenderScanline(). Incr := 1; if Dx = 0 then begin EX := SAR_8(X1); TwoFx := (X1 - (EX shl CPolyBaseShift)) shl 1; First := CPolyBaseSize; if Dy < 0 then begin First := 0; Incr := -1; end; Delta := First - FY1; Inc(FCurCell.Cover, Delta); Inc(FCurCell.Area, TwoFx * Delta); Inc(EY1, Incr); SetCurCell(EX, EY1); Delta := First + First - CPolyBaseSize; Area := TwoFx * Delta; while EY1 <> EY2 do begin FCurCell.Cover := Delta; FCurCell.Area := Area; Inc(EY1, Incr); SetCurCell(EX, EY1); end; Delta := FY2 - CPolyBaseSize + First; Inc(FCurCell.Cover, Delta); Inc(FCurCell.Area, TwoFx * Delta); Exit; end; // ok, we have to render several scanlines P := (CPolyBaseSize - FY1) * Dx; First := CPolyBaseSize; if Dy < 0 then begin P := FY1 * Dx; First := 0; Incr := -1; Dy := -Dy; end; Delta := P div Dy; AMod := P mod Dy; if AMod < 0 then begin Dec(Delta); Inc(AMod, Dy); end; XFrom := X1 + Delta; RenderScanLine(EY1, X1, FY1, XFrom, First); Inc(EY1, Incr); SetCurCell(SAR_8(XFrom), EY1); if EY1 <> EY2 then begin P := CPolyBaseSize * Dx; Lift := P div Dy; Rem := P mod Dy; if Rem < 0 then begin Dec(Lift); Inc(Rem, Dy); end; Dec(AMod, Dy); while EY1 <> EY2 do begin Delta := Lift; Inc(AMod, Rem); if AMod >= 0 then begin Dec(AMod, Dy); Inc(Delta); end; XTo := XFrom + Delta; RenderScanLine(EY1, XFrom, CPolyBaseSize - First, XTo, First); XFrom := XTo; Inc(EY1, Incr); SetCurCell(SAR_8(XFrom), EY1); end; end; RenderScanLine(EY1, XFrom, CPolyBaseSize - First, X2, FY2); end; procedure TOutline.RenderScanLine(EY, X1, Y1, X2, Y2: Integer); var EX1, EX2, FX1, FX2, Delta, P, First, Dx, Incr, Lift, AMod, Rem: Integer; begin EX1 := SAR_8(X1); EX2 := SAR_8(X2); FX1 := X1 and CPolyBaseMask; FX2 := X2 and CPolyBaseMask; // trivial case. Happens often if Y1 = Y2 then begin SetCurCell(EX2, EY); Exit; end; // everything is located in a single cell. That is easy! if EX1 = EX2 then begin Delta := Y2 - Y1; Inc(FCurCell.Cover, Delta); Inc(FCurCell.Area, (FX1 + FX2) * Delta); Exit; end; // ok, we'll have to render a run of adjacent cells on the same scanline... P := (CPolyBaseSize - FX1) * (Y2 - Y1); First := CPolyBaseSize; Incr := 1; Dx := X2 - X1; if Dx < 0 then begin P := FX1 * (Y2 - Y1); First := 0; Incr := -1; Dx := -Dx; end; Delta := P div Dx; AMod := P mod Dx; if AMod < 0 then begin Dec(Delta); Inc(AMod, Dx); end; Inc(FCurCell.Cover, Delta); Inc(FCurCell.Area, (FX1 + First) * Delta); Inc(EX1, Incr); SetCurCell(EX1, EY); Inc(Y1, Delta); if EX1 <> EX2 then begin P := CPolyBaseSize * (Y2 - Y1 + Delta); Lift := P div Dx; Rem := P mod Dx; if Rem < 0 then begin Dec(Lift); Inc(Rem, Dx); end; Dec(AMod, Dx); while EX1 <> EX2 do begin Delta := Lift; Inc(AMod, Rem); if AMod >= 0 then begin Dec(AMod, Dx); Inc(Delta); end; Inc(FCurCell.Cover, Delta); Inc(FCurCell.Area, CPolyBaseSize * Delta); Inc(Y1, Delta); Inc(EX1, Incr); SetCurCell(EX1, EY); end; end; Delta := Y2 - Y1; Inc(FCurCell.Cover, Delta); Inc(FCurCell.Area, (FX2 + CPolyBaseSize - First) * Delta); end; procedure TOutline.SetCurCell(X, Y: Integer); begin if FCurCell.PackedCoord <> (Y shl 16) + X then begin AddCurCell; SetCell(FCurCell, X, Y); end; end; procedure TOutline.SortCells; var SortedPtr, BlockPtr: PPCell; CellPtr: PCell; NB, I: Cardinal; begin if FNumCells = 0 then Exit; if FNumCells > FSortedSize then begin FreeMem(FSortedCells); FSortedSize := FNumCells; GetMem(FSortedCells, (FNumCells + 1) * SizeOf(PCell)); end; SortedPtr := FSortedCells; BlockPtr := FCells; NB := FNumCells shr CCellBlockShift; while NB <> 0 do begin Dec(NB); CellPtr := BlockPtr^; Inc(BlockPtr); I := CCellBlockSize; while I <> 0 do begin Dec(I); SortedPtr^ := CellPtr; Inc(SortedPtr); Inc(CellPtr); end; end; CellPtr := BlockPtr^; I := FNumCells and CCellBlockMask; while I <> 0 do begin Dec(I); SortedPtr^ := CellPtr; Inc(SortedPtr); Inc(CellPtr); end; PPCell(Cardinal(FSortedCells) + FNumCells * SizeOf(PCell))^ := nil; QSortCells(FSortedCells, FNumCells); end; { TPolygonRenderer32AggLite } procedure TPolygonRenderer32AggLite.Render(CellsPtr: Pointer; MinX, MaxX: Integer); var X, Y, Cover, Alpha, Area, Coord: Integer; Cells: PPCell absolute CellsPtr; CurCell, StartCell: PCell; ScanLine: TScanLine; procedure RenderSpan; var NumSpans: Cardinal; BaseX: Integer; Row: PColor32Array; CurX: Integer; Covers: PColor32; NumPix: Integer; BaseCovers: Pointer; CurCount: PWord; CurStartPtr: PPColor32; begin NumSpans := ScanLine.NumSpans; BaseX := ScanLine.BaseX; Row := Bitmap.ScanLine[ScanLine.Y]; BaseCovers := ScanLine.CoversPtr; CurCount := ScanLine.CountsPtr; CurStartPtr := ScanLine.StartPtrs; if Assigned(Filler) then repeat Dec(NumSpans); Inc(CurCount); Inc(CurStartPtr); {$IFDEF FPC} CurX := (PtrInt(CurStartPtr^) - PtrInt(BaseCovers)) div SizeOf(TColor32) + BaseX; {$ELSE} {$IFDEF HAS_NATIVEINT} CurX := (NativeInt(CurStartPtr^) - NativeInt(BaseCovers)) div SizeOf(TColor32) + BaseX; {$ELSE} CurX := (Integer(CurStartPtr^) - Integer(BaseCovers)) div SizeOf(TColor32) + BaseX; {$ENDIF} {$ENDIF} Covers := CurStartPtr^; NumPix := CurCount^; if CurX < 0 then begin Inc(NumPix, CurX); if NumPix <= 0 then Continue; Dec(Covers, CurX); CurX := 0; end; if CurX + NumPix >= Bitmap.Width then begin NumPix := Bitmap.Width - CurX; if NumPix <= 0 then Continue; end; Filler.FillLine(@Row^[CurX], CurX, ScanLine.Y, NumPix, Covers) until NumSpans = 0 else repeat Dec(NumSpans); Inc(CurCount); Inc(CurStartPtr); {$IFDEF FPC} CurX := (PtrInt(CurStartPtr^) - PtrInt(BaseCovers)) div SizeOf(TColor32) + BaseX; {$ELSE} {$IFDEF HAS_NATIVEINT} CurX := (NativeInt(CurStartPtr^) - NativeInt(BaseCovers)) div SizeOf(TColor32) + BaseX; {$ELSE} CurX := (Integer(CurStartPtr^) - Integer(BaseCovers)) div SizeOf(TColor32) + BaseX; {$ENDIF} {$ENDIF} Covers := CurStartPtr^; NumPix := CurCount^; if CurX < 0 then begin Inc(NumPix, CurX); if NumPix <= 0 then Continue; Dec(Covers, CurX); CurX := 0; end; if CurX + NumPix >= Bitmap.Width then begin NumPix := Bitmap.Width - CurX; if NumPix <= 0 then Continue; end; FillSpan(@Row^[CurX], PColor32(Covers), NumPix, Color); until NumSpans = 0; EMMS; end; begin ScanLine := TScanLine.Create(MinX, MaxX); // -32, 64 try Cover := 0; CurCell := Cells^; Inc(Cells); while True do begin StartCell := CurCell; Coord := CurCell^.Pnt.PackedCoord; X := CurCell^.Pnt.X; Y := CurCell^.Pnt.Y; Area := StartCell^.Area; Inc(Cover, StartCell^.Cover); CurCell := Cells^; Inc(Cells); while Assigned(CurCell) do begin if CurCell^.Pnt.PackedCoord <> Coord then Break; Inc(Area, CurCell^.Area); Inc(Cover, CurCell^.Cover); CurCell := Cells^; Inc(Cells); end; if Area <> 0 then begin Alpha := CalculateAlpha(Fillmode, (Cover shl (CPolyBaseShift + 1)) - Area); if Alpha <> 0 then begin if ScanLine.IsReady(Y) <> 0 then begin if (ScanLine.Y >= 0) and (ScanLine.Y < Bitmap.Height) then RenderSpan; ScanLine.ResetSpans; end; ScanLine.AddCell(X, Y, GAMMA_TABLE[Alpha]); end; Inc(X); end; if not Assigned(CurCell) then Break; if CurCell^.Pnt.X > X then begin Alpha := CalculateAlpha(Fillmode, Cover shl (CPolyBaseShift + 1)); if Alpha <> 0 then begin if ScanLine.IsReady(Y) <> 0 then begin if (ScanLine.Y >= 0) and (ScanLine.Y < Bitmap.Height) then RenderSpan; ScanLine.ResetSpans; end; ScanLine.AddSpan(X, Y, CurCell^.Pnt.X - X, GAMMA_TABLE[Alpha]); end; end; end; with ScanLine do if (NumSpans <> 0) and (Y >= 0) and (Y < Bitmap.Height) then RenderSpan; finally ScanLine.Free; end; end; type TBitmap32Access = class(TBitmap32); procedure TPolygonRenderer32AggLite.PolygonFS( const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect); var I: Integer; Cells: PPCell; OutLine: TOutline; APoints: TArrayOfFloatPoint; R: TFloatRect; begin R := ClipRect; InflateRect(R, 0.05, 0.05); APoints := ClipPolygon (Points, R); OutLine := TOutline.Create; try OutLine.Reset; OutLine.MoveTo(Fixed8(APoints[0].X), Fixed8(APoints[0].Y)); for I := 1 to High(APoints) do OutLine.LineTo(Fixed8(APoints[I].X), Fixed8(APoints[I].Y)); // get cells and check count Cells := OutLine.Cells; if OutLine.NumCells = 0 then Exit; if Assigned(Filler) then begin // call begin rendering of assigned filler Filler.BeginRendering; Render(Cells, OutLine.MinX, OutLine.MaxX); // rendering done, call end rendering of assigned filler Filler.EndRendering; end else Render(Cells, OutLine.MinX, OutLine.MaxX); {$IFDEF CHANGENOTIFICATIONS} if TBitmap32Access(Bitmap).UpdateCount = 0 then if Length(APoints) > 0 then Bitmap.Changed(MakeRect(OutLine.MinX, OutLine.MinY, OutLine.MaxX, OutLine.MaxY)); {$ENDIF} finally SetLength(APoints, 0); OutLine.Free; end; end; procedure TPolygonRenderer32AggLite.PolyPolygonFS( const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); var I, J: Integer; Cells: PPCell; OutLine: TOutline; Bounds: TRect; APoints: TArrayOfArrayOfFloatPoint; R: TFloatRect; begin if Length(Points) = 0 then Exit; APoints := Points; // temporary fix for floating point rounding errors - corr. - to + by pws R := ClipRect; InflateRect(R, 0.05, 0.05); for i := 0 to High(APoints) do APoints[i] := ClipPolygon(Points[I], R); OutLine := TOutline.Create; try OutLine.Reset; OutLine.MoveTo(Fixed8(APoints[0, 0].X), Fixed8(APoints[0, 0].Y)); for I := 1 to High(APoints[0]) do OutLine.LineTo(Fixed8(APoints[0, I].X), Fixed8(APoints[0, I].Y)); Bounds := MakeRect(OutLine.MinX, OutLine.MinY, OutLine.MaxX, OutLine.MaxY); for J := 1 to High(APoints) do begin OutLine.MoveTo(Fixed8(APoints[J, 0].X), Fixed8(APoints[J, 0].Y)); for I := 1 to High(APoints[J]) do OutLine.LineTo(Fixed8(APoints[J, I].X), Fixed8(APoints[J, I].Y)); Bounds.Left := Min(Bounds.Left, OutLine.MinX); Bounds.Right := Max(Bounds.Right, OutLine.MaxX); Bounds.Top := Min(Bounds.Top, OutLine.MinY); Bounds.Bottom := Max(Bounds.Bottom, OutLine.MaxY); end; // get cells and check count Cells := OutLine.Cells; if OutLine.NumCells = 0 then Exit; if Assigned(Filler) then begin // call begin rendering of assigned filler Filler.BeginRendering; Render(Cells, Bounds.Left, Bounds.Right); // rendering done, call end rendering of assigned filler Filler.EndRendering; end else Render(Cells, Bounds.Left, Bounds.Right); {$IFDEF CHANGENOTIFICATIONS} if TBitmap32Access(Bitmap).UpdateCount = 0 then for I := 0 to High(APoints) do if Length(APoints[I]) > 0 then Bitmap.Changed(Bounds); {$ENDIF} finally OutLine.Free; SetLength(APoints, 0); end; end; const FID_FILLSPAN = 0; procedure RegisterBindings; begin BlendRegistry := NewRegistry('GR32_PolygonsAggLite bindings'); BlendRegistry.RegisterBinding(FID_FILLSPAN, @@FILLSPAN); // pure pascal BlendRegistry.Add(FID_FILLSPAN, @FILLSPAN_Pas); {$IFNDEF PUREPASCAL} BlendRegistry.Add(FID_FILLSPAN, @FILLSPAN_ASM, []); {$IFNDEF OMIT_MMX} BlendRegistry.Add(FID_FILLSPAN, @FILLSPAN_MMX, [ciMMX]); {$ENDIF} {$IFNDEF OMIT_SSE2} BlendRegistry.Add(FID_FILLSPAN, @FILLSPAN_SSE2, [ciSSE2]); {$ENDIF} {$ENDIF} BlendRegistry.RebindAll; end; initialization RegisterPolygonRenderer(TPolygonRenderer32AggLite); RegisterBindings; finalization end. |
Added src/graphics32/GR32_RangeBars.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 | unit GR32_RangeBars; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Andre Beckedorf <Andre@metaException.de> * Marc Lafon * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LMessages, LCLType, Graphics, Controls, Forms, Dialogs, ExtCtrls, {$IFDEF Windows} Windows, {$ENDIF} {$ELSE} Windows, Messages, {$IFDEF INLININGSUPPORTED}Types,{$ENDIF} Graphics, Controls, Forms, Dialogs, ExtCtrls, {$ENDIF} SysUtils, Classes, GR32; type TRBDirection = (drLeft, drUp, drRight, drDown); TRBDirections = set of TRBDirection; TRBZone = (zNone, zBtnPrev, zTrackPrev, zHandle, zTrackNext, zBtnNext); TRBStyle = (rbsDefault, rbsMac); TRBBackgnd = (bgPattern, bgSolid); TRBGetSizeEvent = procedure(Sender: TObject; var Size: Integer) of object; TArrowBar = class(TCustomControl) private FBackgnd: TRBBackgnd; FBorderStyle: TBorderStyle; FButtonSize: Integer; FHandleColor: TColor; FButtoncolor:TColor; FHighLightColor:TColor; FShadowColor:TColor; FBorderColor:TColor; FKind: TScrollBarKind; FShowArrows: Boolean; FShowHandleGrip: Boolean; FStyle: TRBStyle; FOnChange: TNotifyEvent; FOnUserChange: TNotifyEvent; procedure SetButtonSize(Value: Integer); procedure SetBorderStyle(Value: TBorderStyle); {$IFDEF FPC} override; {$ENDIF} procedure SetHandleColor(Value: TColor); procedure SetHighLightColor(Value: TColor); procedure SetShadowColor(Value: TColor); procedure SetButtonColor(Value: TColor); procedure SetBorderColor(Value: TColor); procedure SetKind(Value: TScrollBarKind); procedure SetShowArrows(Value: Boolean); procedure SetShowHandleGrip(Value: Boolean); procedure SetStyle(Value: TRBStyle); procedure SetBackgnd(Value: TRBBackgnd); {$IFDEF FPC} procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED; procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE; procedure WMNCCalcSize(var Message: TLMNCCalcSize); message LM_NCCALCSIZE; procedure WMEraseBkgnd(var Message: TLmEraseBkgnd); message LM_ERASEBKGND; {$IFDEF Windows} procedure WMNCPaint(var Message: TWMNCPaint); message LM_NCPAINT; {$ENDIF} {$ELSE} procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT; procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND; {$ENDIF} protected FGenChange: Boolean; FDragZone: TRBZone; FHotZone: TRBZone; FTimer: TTimer; FTimerMode: Integer; FStored: TPoint; FPosBeforeDrag: Single; procedure DoChange; virtual; procedure DoDrawButton(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); virtual; procedure DoDrawHandle(R: TRect; Horz: Boolean; Pushed, Hot: Boolean); virtual; procedure DoDrawTrack(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); virtual; function DrawEnabled: Boolean; virtual; function GetBorderSize: Integer; function GetHandleRect: TRect; virtual; function GetButtonSize: Integer; function GetTrackBoundary: TRect; function GetZone(X, Y: Integer): TRBZone; function GetZoneRect(Zone: TRBZone): TRect; procedure MouseLeft; virtual; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure Paint; override; procedure StartDragTracking; procedure StartHotTracking; procedure StopDragTracking; procedure StopHotTracking; procedure TimerHandler(Sender: TObject); virtual; public constructor Create(AOwner: TComponent); override; property Color default clScrollBar; property Backgnd: TRBBackgnd read FBackgnd write SetBackgnd; property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; property ButtonSize: Integer read FButtonSize write SetButtonSize default 0; property HandleColor: TColor read FHandleColor write SetHandleColor default clBtnShadow; property ButtonColor: TColor read FButtonColor write SetButtonColor default clBtnFace; property HighLightColor: TColor read FHighLightColor write SetHighLightColor default clBtnHighlight; property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnShadow; property BorderColor: TColor read FBorderColor write SetBorderColor default clWindowFrame; property Kind: TScrollBarKind read FKind write SetKind default sbHorizontal; property ShowArrows: Boolean read FShowArrows write SetShowArrows default True; property ShowHandleGrip: Boolean read FShowHandleGrip write SetShowHandleGrip; property Style: TRBStyle read FStyle write SetStyle default rbsDefault; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnUserChange: TNotifyEvent read FOnUserChange write FOnUserChange; end; TRBIncrement = 1..32768; TCustomRangeBar = class(TArrowBar) private FCentered: Boolean; FEffectiveWindow: Integer; FIncrement: TRBIncrement; FPosition: Single; FRange: Integer; FWindow: Integer; function IsPositionStored: Boolean; procedure SetPosition(Value: Single); procedure SetRange(Value: Integer); procedure SetWindow(Value: Integer); protected procedure AdjustPosition; function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override; function DrawEnabled: Boolean; override; function GetHandleRect: TRect; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure TimerHandler(Sender: TObject); override; procedure UpdateEffectiveWindow; property EffectiveWindow: Integer read FEffectiveWindow; public constructor Create(AOwner: TComponent); override; procedure Resize; override; procedure SetParams(NewRange, NewWindow: Integer); property Centered: Boolean read FCentered write FCentered; property Increment: TRBIncrement read FIncrement write FIncrement default 8; property Position: Single read FPosition write SetPosition stored IsPositionStored; property Range: Integer read FRange write SetRange default 0; property Window: Integer read FWindow write SetWindow default 0; end; TRangeBar = class(TCustomRangeBar) published property Align; property Anchors; property Constraints; property Color; property Backgnd; property BorderStyle; property ButtonSize; property Enabled; property HandleColor; property ButtonColor; property HighLightColor; property ShadowColor; property BorderColor; property Increment; property Kind; property Range; property Style; property Visible; property Window; property ShowArrows; property ShowHandleGrip; property Position; // this should be located after the Range property property OnChange; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheelUp; property OnMouseWheelDown; property OnStartDrag; property OnUserChange; end; TCustomGaugeBar = class(TArrowBar) private FHandleSize: Integer; FLargeChange: Integer; FMax: Integer; FMin: Integer; FPosition: Integer; FSmallChange: Integer; procedure SetHandleSize(Value: Integer); procedure SetMax(Value: Integer); procedure SetMin(Value: Integer); procedure SetPosition(Value: Integer); procedure SetLargeChange(Value: Integer); procedure SetSmallChange(Value: Integer); protected procedure AdjustPosition; function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override; function GetHandleRect: TRect; override; function GetHandleSize: Integer; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure TimerHandler(Sender: TObject); override; public constructor Create(AOwner: TComponent); override; property HandleSize: Integer read FHandleSize write SetHandleSize default 0; property LargeChange: Integer read FLargeChange write SetLargeChange default 1; property Max: Integer read FMax write SetMax default 100; property Min: Integer read FMin write SetMin default 0; property Position: Integer read FPosition write SetPosition; property SmallChange: Integer read FSmallChange write SetSmallChange default 1; property OnChange; property OnUserChange; end; TGaugeBar = class(TCustomGaugeBar) published property Align; property Anchors; property Constraints; property Color; property Backgnd; property BorderStyle; property ButtonSize; property Enabled; property HandleColor; property ButtonColor; property HighLightColor; property ShadowColor; property BorderColor; property HandleSize; property Kind; property LargeChange; property Max; property Min; property ShowArrows; property ShowHandleGrip; property Style; property SmallChange; property Visible; property Position; property OnChange; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDrag; property OnUserChange; end; { TArrowBarAccess } { This class is designed to facilitate access to properties of TArrowBar class when creating custom controls, which incorporate TArrowBar. It allows controlling up to two arrow bars. Master is used to read and write properties, slave - only to write. Well, maybe it is not so useful itself, but it is a common ancestor for TRangeBarAccess and TGaugeBarAccess classes, which work much the same way. When writing a new control, which uses TArrowBar, declare the bar as protected member, TArrowBarAccess as published property, and assign its Master to the arrow bar } TArrowBarAccess = class(TPersistent) private FMaster: TArrowBar; FSlave: TArrowBar; function GetBackgnd: TRBBackgnd; function GetButtonSize: Integer; function GetColor: TColor; function GetHandleColor: TColor; function GetHighLightColor: TColor; function GetButtonColor: TColor; function GetBorderColor: TColor; function GetShadowColor: TColor; function GetShowArrows: Boolean; function GetShowHandleGrip: Boolean; function GetStyle: TRBStyle; procedure SetBackgnd(Value: TRBBackgnd); procedure SetButtonSize(Value: Integer); procedure SetColor(Value: TColor); procedure SetHandleColor(Value: TColor); procedure SetShowArrows(Value: Boolean); procedure SetShowHandleGrip(Value: Boolean); procedure SetStyle(Value: TRBStyle); procedure SetHighLightColor(Value: TColor); procedure SetShadowColor(Value: TColor); procedure SetButtonColor(Value: TColor); procedure SetBorderColor(Value: TColor); public property Master: TArrowBar read FMaster write FMaster; property Slave: TArrowBar read FSlave write FSlave; published property Color: TColor read GetColor write SetColor default clScrollBar; property Backgnd: TRBBackgnd read GetBackgnd write SetBackgnd default bgPattern; property ButtonSize: Integer read GetButtonSize write SetButtonSize default 0; property HandleColor: TColor read GetHandleColor write SetHandleColor default clBtnShadow; property ButtonColor:TColor read GetButtonColor write SetButtonColor default clBtnFace; property HighLightColor:TColor read GetHighLightColor write SetHighLightColor default clBtnHighlight; property ShadowColor:TColor read GetShadowColor write SetShadowColor default clBtnShadow; property BorderColor:TColor read GetBorderColor write SetBorderColor default clWindowFrame; property ShowArrows: Boolean read GetShowArrows write SetShowArrows default True; property ShowHandleGrip: Boolean read GetShowHandleGrip write SetShowHandleGrip; property Style: TRBStyle read GetStyle write SetStyle; end; implementation uses Math, GR32_XPThemes; const OppositeDirection: array [TRBDirection] of TRBDirection = (drRight, drDown, drLeft, drUp); tmScrollFirst = 1; tmScroll = 2; tmHotTrack = 3; function ClrLighten(C: TColor; Amount: Integer): TColor; var R, G, B: Integer; begin {$IFDEF Windows} if C < 0 then C := GetSysColor(C and $000000FF); {$ELSE} C := ColorToRGB(C); {$ENDIF} R := C and $FF + Amount; G := C shr 8 and $FF + Amount; B := C shr 16 and $FF + Amount; if R < 0 then R := 0 else if R > 255 then R := 255; if G < 0 then G := 0 else if G > 255 then G := 255; if B < 0 then B := 0 else if B > 255 then B := 255; Result := R or (G shl 8) or (B shl 16); end; function MixColors(C1, C2: TColor; W1: Integer): TColor; var W2: Cardinal; begin Assert(W1 in [0..255]); W2 := W1 xor 255; {$IFDEF Windows} if Integer(C1) < 0 then C1 := GetSysColor(C1 and $000000FF); if Integer(C2) < 0 then C2 := GetSysColor(C2 and $000000FF); {$ELSE} C1 := ColorToRGB(C1); C2 := ColorToRGB(C2); {$ENDIF} Result := Integer( ((Cardinal(C1) and $FF00FF) * Cardinal(W1) + (Cardinal(C2) and $FF00FF) * W2) and $FF00FF00 + ((Cardinal(C1) and $00FF00) * Cardinal(W1) + (Cardinal(C2) and $00FF00) * W2) and $00FF0000) shr 8; end; procedure DitherRect(Canvas: TCanvas; const R: TRect; C1, C2: TColor); var {$IFDEF FPC} Brush: TBrush; OldBrush: TBrush; {$ELSE} B: TBitmap; Brush: HBRUSH; {$ENDIF} begin if GR32.IsRectEmpty(R) then Exit; {$IFDEF FPC} Brush := TBrush.Create; try Brush.Color := ColorToRGB(C1); if C1 <> C2 then begin Brush.Bitmap := Graphics.TBitmap.Create; with Brush.Bitmap do begin Height := 2; Width := 2; Canvas.Pixels[0,0] := C1; Canvas.Pixels[1,0] := C2; Canvas.Pixels[0,1] := C2; Canvas.Pixels[1,1] := C1; end; Brush.Color := ColorToRGB(C1); end; OldBrush := TBrush.Create; try OldBrush.Assign(Canvas.Brush); Canvas.Brush.Assign(Brush); Canvas.FillRect(R); Canvas.Brush.Assign(OldBrush); finally OldBrush.Free; end; finally if Assigned(Brush.Bitmap) then Brush.Bitmap.Free; Brush.Free; end; {$ELSE} if C1 = C2 then Brush := CreateSolidBrush(ColorToRGB(C1)) else begin B := AllocPatternBitmap(C1, C2); B.HandleType := bmDDB; Brush := CreatePatternBrush(B.Handle); end; FillRect(Canvas.Handle, R, Brush); DeleteObject(Brush); {$ENDIF} end; procedure DrawRectEx(Canvas: TCanvas; var R: TRect; Sides: TRBDirections; C: TColor); begin if Sides <> [] then with Canvas, R do begin Pen.Color := C; if drUp in Sides then begin MoveTo(Left, Top); LineTo(Right, Top); Inc(Top); end; if drDown in Sides then begin Dec(Bottom); MoveTo(Left, Bottom); LineTo(Right, Bottom); end; if drLeft in Sides then begin MoveTo(Left, Top); LineTo(Left, Bottom); Inc(Left); end; if drRight in Sides then begin Dec(Right); MoveTo(Right, Top); LineTo(Right, Bottom); end; end; end; procedure Frame3D(Canvas: TCanvas; var ARect: TRect; TopColor, BottomColor: TColor; AdjustRect: Boolean = True); var TopRight, BottomLeft: TPoint; begin with Canvas, ARect do begin Pen.Width := 1; Dec(Bottom); Dec(Right); TopRight.X := Right; TopRight.Y := Top; BottomLeft.X := Left; BottomLeft.Y := Bottom; Pen.Color := TopColor; PolyLine([BottomLeft, TopLeft, TopRight]); Pen.Color := BottomColor; Dec(Left); PolyLine([TopRight, BottomRight, BottomLeft]); if AdjustRect then begin Inc(Top); Inc(Left, 2); end else begin Inc(Left); Inc(Bottom); Inc(Right); end; end; end; procedure DrawHandle(Canvas: TCanvas; R: TRect; Color: TColor; Pushed, ShowGrip, IsHorz: Boolean; ColorBorder: TColor); var CHi, CLo: TColor; I, S: Integer; begin CHi := ClrLighten(Color, 24); CLo := ClrLighten(Color, -24); Canvas.Brush.Color := ColorBorder; FrameRect(Canvas.Handle, R, Canvas.Brush.Handle); GR32.InflateRect(R, -1, -1); if Pushed then Frame3D(Canvas, R, CLo, Color) else Frame3D(Canvas, R, CHi, MixColors(ColorBorder, Color, 96)); Canvas.Brush.Color := Color; Canvas.FillRect(R); if ShowGrip then begin if Pushed then GR32.OffsetRect(R, 1, 1); if IsHorz then begin S := R.Right - R.Left; R.Left := (R.Left + R.Right) div 2 - 5; R.Right := R.Left + 2; Inc(R.Top); Dec(R.Bottom); if S > 10 then Frame3D(Canvas, R, CHi, CLo, False); Inc(R.Left, 3); Inc(R.Right, 3); Frame3D(Canvas, R, CHi, CLo, False); Inc(R.Left, 3); Inc(R.Right, 3); Frame3D(Canvas, R, CHi, CLo, False); Inc(R.Left, 3); Inc(R.Right, 3); if S > 10 then Frame3D(Canvas, R, CHi, CLo, False); end else begin I := (R.Top + R.Bottom) div 2; S := R.Bottom - R.Top; R.Top := I - 1; R.Bottom := I + 1; Dec(R.Right); Inc(R.Left); GR32.OffsetRect(R, 0, -4); if S > 10 then Frame3D(Canvas, R, CHi, CLo, False); GR32.OffsetRect(R, 0, 3); Frame3D(Canvas, R, CHi, CLo, False); GR32.OffsetRect(R, 0, 3); Frame3D(Canvas, R, CHi, CLo, False); if S > 10 then begin GR32.OffsetRect(R, 0, 3); Frame3D(Canvas, R, CHi, CLo, False); end; end; end; end; procedure DrawArrow(Canvas: TCanvas; R: TRect; Direction: TRBDirection; Color: TColor); var X, Y, Sz, Shift: Integer; begin X := (R.Left + R.Right - 1) div 2; Y := (R.Top + R.Bottom - 1) div 2; Sz := (Min(X - R.Left, Y - R.Top)) * 3 div 4 - 1; if Sz = 0 then Sz := 1; if Direction in [drUp, drLeft] then Shift := (Sz + 1) * 1 div 3 else Shift := Sz * 1 div 3; Canvas.Pen.Color := Color; Canvas.Brush.Color := Color; case Direction of drUp: begin Inc(Y, Shift); Canvas.Polygon([Point(X + Sz, Y), Point(X, Y - Sz), Point(X - Sz, Y)]); end; drDown: begin Dec(Y, Shift); Canvas.Polygon([Point(X + Sz, Y), Point(X, Y + Sz), Point(X - Sz, Y)]); end; drLeft: begin Inc(X, Shift); Canvas.Polygon([Point(X, Y + Sz), Point(X - Sz, Y), Point(X, Y - Sz)]); end; drRight: begin Dec(X, Shift); Canvas.Polygon([Point(X, Y + Sz), Point(X + Sz, Y), Point(X, Y - Sz)]); end; end; end; const FIRST_DELAY = 600; SCROLL_INTERVAL = 100; HOTTRACK_INTERVAL = 150; MIN_SIZE = 17; { TArrowBar } {$IFDEF FPC} procedure TArrowBar.CMEnabledChanged(var Message: TLMessage); {$ELSE} procedure TArrowBar.CMEnabledChanged(var Message: TMessage); {$ENDIF} begin inherited; Invalidate; end; {$IFDEF FPC} procedure TArrowBar.CMMouseLeave(var Message: TLMessage); {$ELSE} procedure TArrowBar.CMMouseLeave(var Message: TMessage); {$ENDIF} begin MouseLeft; inherited; end; constructor TArrowBar.Create(AOwner: TComponent); begin inherited; ControlStyle := ControlStyle - [csAcceptsControls, csDoubleClicks] + [csOpaque]; Width := 100; Height := 16; ParentColor := False; Color := clScrollBar; FTimer := TTimer.Create(Self); FTimer.OnTimer := TimerHandler; FShowArrows := True; FBorderStyle := bsSingle; FHandleColor := clBtnShadow; FButtonColor := clBtnFace; FHighLightColor := clBtnHighlight; FShadowColor := clBtnShadow; FBorderColor := clWindowFrame; FShowHandleGrip := True; end; procedure TArrowBar.DoChange; begin if Assigned(FOnChange) then FOnChange(Self); if FGenChange and Assigned(FOnUserChange) then FOnUserChange(Self); end; procedure TArrowBar.DoDrawButton(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); const EnabledFlags: array [Boolean] of Integer = (DFCS_INACTIVE, 0); PushedFlags: array [Boolean] of Integer = (0, DFCS_PUSHED or DFCS_FLAT); DirectionFlags: array [TRBDirection] of Integer = (DFCS_SCROLLLEFT, DFCS_SCROLLUP, DFCS_SCROLLRIGHT, DFCS_SCROLLDOWN); {$IFDEF Windows} DirectionXPFlags: array [TRBDirection] of Cardinal = (ABS_LEFTNORMAL, ABS_UPNORMAL, ABS_RIGHTNORMAL, ABS_DOWNNORMAL); {$ENDIF} var Edges: TRBDirections; {$IFDEF Windows} Flags: Integer; {$ENDIF} begin if Style = rbsDefault then begin {$IFDEF FPC} {$IFNDEF Windows} Canvas.Brush.Color := clButton; Canvas.FillRect(R); LCLIntf.DrawFrameControl(Canvas.Handle, R, DFC_BUTTON, 0); InflateRect(R, -2, -2); If not DrawEnabled then begin InflateRect(R, -1, -1); OffsetRect(R, 1, 1); DrawArrow(Canvas, R, Direction, clWhite); OffsetRect(R, -1, -1); DrawArrow(Canvas, R, Direction, clDisabledButtonText); end else begin If Pushed then OffsetRect(R, 1, 1); DrawArrow(Canvas, R, Direction, clButtonText); end; {$ENDIF} {$ENDIF} {$IFDEF Windows} if USE_THEMES then begin Flags := DirectionXPFlags[Direction]; if not Enabled then Inc(Flags, 3) else if Pushed then Inc(Flags, 2) else if Hot then Inc(Flags); DrawThemeBackground(SCROLLBAR_THEME, Canvas.Handle, SBP_ARROWBTN, Flags, R, nil); end else DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, DirectionFlags[Direction] or EnabledFlags[DrawEnabled] or PushedFlags[Pushed]) {$ENDIF} end else begin Edges := [drLeft, drUp, drRight, drDown]; Exclude(Edges, OppositeDirection[Direction]); if not DrawEnabled then begin DrawRectEx(Canvas, R, Edges, fShadowColor); Canvas.Brush.Color := fButtonColor; FillRect(Canvas.Handle, R, Canvas.Brush.Handle); GR32.InflateRect(R, -1, -1); GR32.OffsetRect(R, 1, 1); DrawArrow(Canvas, R, Direction, fHighLightColor); GR32.OffsetRect(R, -1, -1); DrawArrow(Canvas, R, Direction, fShadowColor); end else begin DrawRectEx(Canvas, R, Edges, fBorderColor); if Pushed then begin Canvas.Brush.Color := fButtonColor; FillRect(Canvas.Handle, R, Canvas.Brush.Handle); GR32.OffsetRect(R, 1, 1); GR32.InflateRect(R, -1, -1); end else begin Frame3D(Canvas, R, fHighLightColor, fShadowColor, True); Canvas.Brush.Color := fButtonColor; FillRect(Canvas.Handle, R, Canvas.Brush.Handle); end; DrawArrow(Canvas, R, Direction, fBorderColor); end; end; end; procedure TArrowBar.DoDrawHandle(R: TRect; Horz, Pushed, Hot: Boolean); {$IFDEF Windows} const PartXPFlags: array [Boolean] of Cardinal = (SBP_THUMBBTNVERT, SBP_THUMBBTNHORZ); GripperFlags: array [Boolean] of Cardinal = (SBP_GRIPPERVERT, SBP_GRIPPERHORZ); var Flags: Cardinal; {$ENDIF} begin if GR32.IsRectEmpty(R) then Exit; case Style of rbsDefault: begin {$IFDEF Windows} if USE_THEMES then begin Flags := SCRBS_NORMAL; if not Enabled then Inc(Flags, 3) else if Pushed then Inc(Flags, 2) else if Hot then Inc(Flags); DrawThemeBackground(SCROLLBAR_THEME, Canvas.Handle, PartXPFlags[Horz], Flags, R, nil); if ShowHandleGrip then DrawThemeBackground(SCROLLBAR_THEME, Canvas.Handle, GripperFlags[Horz], 0, R, nil); end else DrawEdge(Canvas.Handle, R, EDGE_RAISED, BF_RECT or BF_MIDDLE); {$ENDIF} end; rbsMac: begin DrawHandle(Canvas, R, HandleColor, Pushed, ShowHandleGrip, Horz, fBorderColor); end; end; end; procedure TArrowBar.DoDrawTrack(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); {$IFDEF Windows} const PartXPFlags: array [TRBDirection] of Cardinal = (SBP_LOWERTRACKHORZ, SBP_LOWERTRACKVERT, SBP_UPPERTRACKHORZ, SBP_UPPERTRACKVERT); {$ENDIF} var {$IFDEF Windows} Flags: Cardinal; {$ENDIF} C: TColor; Edges: set of TRBDirection; begin if (R.Right <= R.Left) or (R.Bottom <= R.Top) then Exit; if Style = rbsDefault then begin {$IFDEF Windows} if USE_THEMES then begin Flags := SCRBS_NORMAL; if Pushed then Inc(Flags, 2); DrawThemeBackground(SCROLLBAR_THEME, Canvas.Handle, PartXPFlags[Direction], Flags, R, nil); end else {$ENDIF} begin if Pushed then DitherRect(Canvas, R, clWindowFrame, clWindowFrame) else DitherRect(Canvas, R, clBtnHighlight, Color); end; end else with Canvas, R do begin if DrawEnabled then C := FBorderColor else C := FShadowColor; Edges := [drLeft, drUp, drRight, drDown]; Exclude(Edges, OppositeDirection[Direction]); DrawRectEx(Canvas, R, Edges, C); if Pushed then DitherRect(Canvas, R, fBorderColor,fBorderColor) else if not GR32.IsRectEmpty(R) then with R do begin if DrawEnabled then begin Pen.Color := MixColors(fBorderColor, MixColors(fHighLightColor, Color, 127), 32); case Direction of drLeft, drUp: begin MoveTo(Left, Bottom - 1); LineTo(Left, Top); LineTo(Right, Top); Inc(Top); Inc(Left); end; drRight: begin MoveTo(Left, Top); LineTo(Right, Top); Inc(Top); end; drDown: begin MoveTo(Left, Top); LineTo(Left, Bottom); Inc(Left); end; end; if Backgnd = bgPattern then DitherRect(Canvas, R, fHighLightColor, Color) else DitherRect(Canvas, R, Color, Color); end else begin Brush.Color := fButtonColor; FillRect(R); end; end; end; end; function TArrowBar.DrawEnabled: Boolean; begin Result := Enabled; end; function TArrowBar.GetBorderSize: Integer; const CSize: array [Boolean] of Integer = (0, 1); begin Result := CSize[BorderStyle = bsSingle]; end; function TArrowBar.GetButtonSize: Integer; var W, H: Integer; begin if not ShowArrows then Result := 0 else begin Result := ButtonSize; if Kind = sbHorizontal then begin W := ClientWidth; H := ClientHeight; end else begin W := ClientHeight; H := ClientWidth; end; if Result = 0 then Result := Min(H, 32); if Result * 2 >= W then Result := W div 2; if Style = rbsMac then Dec(Result); if Result < 2 then Result := 0; end; end; function TArrowBar.GetHandleRect: TRect; begin Result := Rect(0, 0, 0, 0); end; function TArrowBar.GetTrackBoundary: TRect; begin Result := ClientRect; if Kind = sbHorizontal then GR32.InflateRect(Result, -GetButtonSize, 0) else GR32.InflateRect(Result, 0, -GetButtonSize); end; function TArrowBar.GetZone(X, Y: Integer): TRBZone; var P: TPoint; R, R1: TRect; Sz: Integer; begin Result := zNone; P := Point(X, Y); R := ClientRect; if not GR32.PtInrect(R, P) then Exit; Sz := GetButtonSize; R1 := R; if Kind = sbHorizontal then begin R1.Right := R1.Left + Sz; if GR32.PtInRect(R1, P) then Result := zBtnPrev else begin R1.Right := R.Right; R1.Left := R.Right - Sz; if GR32.PtInRect(R1, P) then Result := zBtnNext; end; end else begin R1.Bottom := R1.Top + Sz; if GR32.PtInRect(R1, P) then Result := zBtnPrev else begin R1.Bottom := R.Bottom; R1.Top := R.Bottom - Sz; if GR32.PtInRect(R1, P) then Result := zBtnNext; end; end; if Result = zNone then begin R := GetHandleRect; P := Point(X, Y); if GR32.PtInRect(R, P) then Result := zHandle else begin if Kind = sbHorizontal then begin if (X > 0) and (X < R.Left) then Result := zTrackPrev else if (X >= R.Right) and (X < ClientWidth - 1) then Result := zTrackNext; end else begin if (Y > 0) and (Y < R.Top) then Result := zTrackPrev else if (Y >= R.Bottom) and (Y < ClientHeight - 1) then Result := zTrackNext; end; end; end; end; function TArrowBar.GetZoneRect(Zone: TRBZone): TRect; const CEmptyRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0); var BtnSize: Integer; Horz: Boolean; R: TRect; begin Horz := Kind = sbHorizontal; BtnSize:= GetButtonSize; case Zone of zNone: Result := CEmptyRect; zBtnPrev: begin Result := ClientRect; if Horz then Result.Right := Result.Left + BtnSize else Result.Bottom := Result.Top + BtnSize; end; zTrackPrev..zTrackNext: begin Result := GetTrackBoundary; R := GetHandleRect; if not DrawEnabled or GR32.IsRectEmpty(R) then begin R.Left := (Result.Left + Result.Right) div 2; R.Top := (Result.Top + Result.Bottom) div 2; R.Right := R.Left; R.Bottom := R.Top; end; case Zone of zTrackPrev: if Horz then Result.Right := R.Left else Result.Bottom := R.Top; zHandle: Result := R; zTrackNext: if Horz then Result.Left := R.Right else Result.Top := R.Bottom; end; end; zBtnNext: begin Result := ClientRect; if Horz then Result.Left := Result.Right - BtnSize else Result.Top := Result.Bottom - BtnSize; end; end; end; procedure TArrowBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; if Button <> mbLeft then Exit; FDragZone := GetZone(X, Y); Invalidate; FStored.X := X; FStored.Y := Y; StartDragTracking; end; procedure TArrowBar.MouseLeft; begin StopHotTracking; end; procedure TArrowBar.MouseMove(Shift: TShiftState; X, Y: Integer); var NewHotZone: TRBZone; begin inherited; if (FDragZone = zNone) and DrawEnabled then begin NewHotZone := GetZone(X, Y); if NewHotZone <> FHotZone then begin FHotZone := NewHotZone; if FHotZone <> zNone then StartHotTracking; Invalidate; end; end; end; procedure TArrowBar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; FDragZone := zNone; Invalidate; StopDragTracking; end; procedure TArrowBar.Paint; const CPrevDirs: array [Boolean] of TRBDirection = (drUp, drLeft); CNextDirs: array [Boolean] of TRBDirection = (drDown, drRight); var BSize: Integer; ShowEnabled: Boolean; R, BtnRect, HandleRect: TRect; Horz, ShowHandle: Boolean; begin R := ClientRect; Horz := Kind = sbHorizontal; ShowEnabled := DrawEnabled; BSize := GetButtonSize; if ShowArrows then begin { left / top button } BtnRect := R; with BtnRect do if Horz then Right := Left + BSize else Bottom := Top + BSize; DoDrawButton(BtnRect, CPrevDirs[Horz], FDragZone = zBtnPrev, ShowEnabled, FHotZone = zBtnPrev); { right / bottom button } BtnRect := R; with BtnRect do if Horz then Left := Right - BSize else Top := Bottom - BSize; DoDrawButton(BtnRect, CNextDirs[Horz], FDragZone = zBtnNext, ShowEnabled, FHotZone = zBtnNext); end; if Horz then GR32.InflateRect(R, -BSize, 0) else GR32.InflateRect(R, 0, -BSize); if ShowEnabled then HandleRect := GetHandleRect else HandleRect := Rect(0, 0, 0, 0); ShowHandle := not GR32.IsRectEmpty(HandleRect); DoDrawTrack(GetZoneRect(zTrackPrev), CPrevDirs[Horz], FDragZone = zTrackPrev, ShowEnabled, FHotZone = zTrackPrev); DoDrawTrack(GetZoneRect(zTrackNext), CNextDirs[Horz], FDragZone = zTrackNext, ShowEnabled, FHotZone = zTrackNext); if ShowHandle then DoDrawHandle(HandleRect, Horz, FDragZone = zHandle, FHotZone = zHandle); end; procedure TArrowBar.SetBackgnd(Value: TRBBackgnd); begin if Value <> FBackgnd then begin FBackgnd := Value; Invalidate; end; end; procedure TArrowBar.SetBorderStyle(Value: TBorderStyle); begin if Value <> FBorderStyle then begin FBorderStyle := Value; {$IFNDEF FPC} RecreateWnd; {$ELSE} Invalidate; {$ENDIF} end; end; procedure TArrowBar.SetButtonSize(Value: Integer); begin if Value <> FButtonSize then begin FButtonSize := Value; Invalidate; end; end; procedure TArrowBar.SetHandleColor(Value: TColor); begin if Value <> FHandleColor then begin FHandleColor := Value; Invalidate; end; end; procedure TArrowBar.SetHighLightColor(Value: TColor); begin if Value <> FHighLightColor then begin FHighLightColor := Value; Invalidate; end; end; procedure TArrowBar.SetButtonColor(Value: TColor); begin if Value <> FButtonColor then begin FButtonColor := Value; Invalidate; end; end; procedure TArrowBar.SetBorderColor(Value: TColor); begin if Value <> FBorderColor then begin FBorderColor := Value; Invalidate; end; end; procedure TArrowBar.SetShadowColor(Value: TColor); begin if Value <> FShadowColor then begin FShadowColor := Value; Invalidate; end; end; procedure TArrowBar.SetKind(Value: TScrollBarKind); var Tmp: Integer; begin if Value <> FKind then begin FKind := Value; if (csDesigning in ComponentState) and not (csLoading in ComponentState) then begin Tmp := Width; Width := Height; Height := Tmp; end; Invalidate; end; end; procedure TArrowBar.SetShowArrows(Value: Boolean); begin if Value <> FShowArrows then begin FShowArrows := Value; Invalidate; end; end; procedure TArrowBar.SetShowHandleGrip(Value: Boolean); begin if Value <> FShowHandleGrip then begin FShowHandleGrip := Value; Invalidate; end; end; procedure TArrowBar.SetStyle(Value: TRBStyle); begin FStyle := Value; {$IFDEF FPC} Invalidate; {$ELSE} RecreateWnd; {$ENDIF} end; procedure TArrowBar.StartDragTracking; begin FTimer.Interval := FIRST_DELAY; FTimerMode := tmScroll; TimerHandler(Self); FTimerMode := tmScrollFirst; FTimer.Enabled := True; end; procedure TArrowBar.StartHotTracking; begin FTimer.Interval := HOTTRACK_INTERVAL; FTimerMode := tmHotTrack; FTimer.Enabled := True; end; procedure TArrowBar.StopDragTracking; begin StartHotTracking; end; procedure TArrowBar.StopHotTracking; begin FTimer.Enabled := False; FHotZone := zNone; Invalidate; end; procedure TArrowBar.TimerHandler(Sender: TObject); var Pt: TPoint; begin case FTimerMode of tmScrollFirst: begin FTimer.Interval := SCROLL_INTERVAL; FTimerMode := tmScroll; end; tmHotTrack: begin Pt := ScreenToClient(Mouse.CursorPos); if not GR32.PtInRect(ClientRect, Pt) then begin StopHotTracking; Invalidate; end; end; end; end; {$IFDEF FPC} procedure TArrowBar.WMEraseBkgnd(var Message: TLmEraseBkgnd); begin Message.Result := -1; end; procedure TArrowBar.WMNCCalcSize(var Message: TLMNCCalcSize); var Sz: Integer; begin Sz := GetBorderSize; GR32.InflateRect(Message.CalcSize_Params.rgrc[0], -Sz, -Sz); end; {$IFDEF Windows} procedure TArrowBar.WMNCPaint(var Message: TWMNCPaint); procedure DrawNCArea(ADC: HDC; const Clip: HRGN); var DC: HDC; R: TRect; begin if BorderStyle = bsNone then Exit; if ADC = 0 then DC := GetWindowDC(Handle) else DC := ADC; try GetWindowRect(Handle, R); OffsetRect(R, -R.Left, -R.Top); DrawEdge(DC, R, BDR_SUNKENOUTER, BF_RECT); finally if ADC = 0 then ReleaseDC(Handle, DC); end; end; begin DrawNCArea(0, Message.RGN); end; {$ENDIF} {$ELSE} procedure TArrowBar.WMEraseBkgnd(var Message: TWmEraseBkgnd); begin Message.Result := -1; end; procedure TArrowBar.WMNCCalcSize(var Message: TWMNCCalcSize); var Sz: Integer; begin Sz := GetBorderSize; GR32.InflateRect(Message.CalcSize_Params.rgrc[0], -Sz, -Sz); end; procedure TArrowBar.WMNCPaint(var Message: TWMNCPaint); procedure DrawNCArea(ADC: HDC; const Clip: HRGN); var DC: HDC; R: TRect; begin if BorderStyle = bsNone then Exit; if ADC = 0 then DC := GetWindowDC(Handle) else DC := ADC; try GetWindowRect(Handle, R); GR32.OffsetRect(R, -R.Left, -R.Top); DrawEdge(DC, R, BDR_SUNKENOUTER, BF_RECT); finally if ADC = 0 then ReleaseDC(Handle, DC); end; end; begin DrawNCArea(0, Message.RGN); end; {$ENDIF} { TCustomRangeBar } procedure TCustomRangeBar.AdjustPosition; begin if FPosition > Range - EffectiveWindow then FPosition := Range - EffectiveWindow; if FPosition < 0 then FPosition := 0; end; constructor TCustomRangeBar.Create(AOwner: TComponent); begin inherited; FIncrement := 8; end; function TCustomRangeBar.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; const OneHundredTwenteenth = 1 / 120; begin Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos); if not Result then Position := Position + Increment * WheelDelta * OneHundredTwenteenth; Result := True; end; function TCustomRangeBar.DrawEnabled: Boolean; begin Result := Enabled and (Range > EffectiveWindow); end; function TCustomRangeBar.GetHandleRect: TRect; var BtnSz, ClientSz: Integer; HandleSz, HandlePos: Integer; R: TRect; Horz: Boolean; begin R := Rect(0, 0, ClientWidth, ClientHeight); Horz := Kind = sbHorizontal; BtnSz := GetButtonSize; if Horz then begin GR32.InflateRect(R, -BtnSz, 0); ClientSz := R.Right - R.Left; end else begin GR32.InflateRect(R, 0, -BtnSz); ClientSz := R.Bottom - R.Top; end; if ClientSz < 18 then begin Result := Rect(0, 0, 0, 0); Exit; end; if Range > EffectiveWindow then begin HandleSz := Round(ClientSz * EffectiveWindow / Range); if HandleSz >= MIN_SIZE then HandlePos := Round(ClientSz * Position / Range) else begin HandleSz := MIN_SIZE; HandlePos := Round((ClientSz - MIN_SIZE) * Position / (Range - EffectiveWindow)); end; Result := R; if Horz then begin Result.Left := R.Left + HandlePos; Result.Right := R.Left + HandlePos + HandleSz; end else begin Result.Top := R.Top + HandlePos; Result.Bottom := R.Top + HandlePos + HandleSz; end; end else Result := R; end; function TCustomRangeBar.IsPositionStored: Boolean; begin Result := FPosition > 0; end; procedure TCustomRangeBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Range <= EffectiveWindow then FDragZone := zNone else begin inherited; if FDragZone = zHandle then begin StopDragTracking; FPosBeforeDrag := Position; end; end; end; procedure TCustomRangeBar.MouseMove(Shift: TShiftState; X, Y: Integer); var Delta: Single; WinSz: Single; ClientSz, HandleSz: Integer; begin inherited; if FDragZone = zHandle then begin WinSz := EffectiveWindow; if Range <= WinSz then Exit; if Kind = sbHorizontal then Delta := X - FStored.X else Delta := Y - FStored.Y; if Kind = sbHorizontal then ClientSz := ClientWidth else ClientSz := ClientHeight; Dec(ClientSz, GetButtonSize * 2); if BorderStyle = bsSingle then Dec(ClientSz, 2); HandleSz := Round(ClientSz * WinSz / Range); if HandleSz < MIN_SIZE then Delta := Round(Delta * (Range - WinSz) / (ClientSz - MIN_SIZE)) else Delta := Delta * Range / ClientSz; FGenChange := True; Position := FPosBeforeDrag + Delta; FGenChange := False; end; end; procedure TCustomRangeBar.Resize; var OldWindow: Integer; Center: Single; begin if Centered then begin OldWindow := EffectiveWindow; UpdateEffectiveWindow; if Range > EffectiveWindow then begin if (Range > OldWindow) and (Range <> 0) then Center := (FPosition + OldWindow * 0.5) / Range else Center := 0.5; FPosition := Center * Range - EffectiveWindow * 0.5; end; end; AdjustPosition; inherited; end; procedure TCustomRangeBar.SetParams(NewRange, NewWindow: Integer); var OldWindow, OldRange: Integer; Center: Single; begin if NewRange < 0 then NewRange := 0; if NewWindow < 0 then NewWindow := 0; if (NewRange <> FRange) or (NewWindow <> EffectiveWindow) then begin OldWindow := EffectiveWindow; OldRange := Range; FRange := NewRange; FWindow := NewWindow; UpdateEffectiveWindow; if Centered and (Range > EffectiveWindow) then begin if (OldRange > OldWindow) and (OldRange <> 0) then Center := (FPosition + OldWindow * 0.5) / OldRange else Center := 0.5; FPosition := Center * Range - EffectiveWindow * 0.5; end; AdjustPosition; Invalidate; end; end; procedure TCustomRangeBar.SetPosition(Value: Single); var OldPosition: Single; begin if Value <> FPosition then begin OldPosition := FPosition; FPosition := Value; AdjustPosition; if OldPosition <> FPosition then begin Invalidate; DoChange; end; end; end; procedure TCustomRangeBar.SetRange(Value: Integer); begin SetParams(Value, Window); end; procedure TCustomRangeBar.SetWindow(Value: Integer); begin SetParams(Range, Value); end; procedure TCustomRangeBar.TimerHandler(Sender: TObject); var OldPosition: Single; Pt: TPoint; function MousePos: TPoint; begin Result := ScreenToClient(Mouse.CursorPos); if Result.X < 0 then Result.X := 0; if Result.Y < 0 then Result.Y := 0; if Result.X >= ClientWidth then Result.X := ClientWidth - 1; if Result.Y >= ClientHeight then Result.Y := ClientHeight - 1 end; begin inherited; FGenChange := True; OldPosition := Position; case FDragZone of zBtnPrev: begin Position := Position - Increment; if Position = OldPosition then StopDragTracking; end; zBtnNext: begin Position := Position + Increment; if Position = OldPosition then StopDragTracking; end; zTrackNext: begin Pt := MousePos; if GetZone(Pt.X, Pt.Y) in [zTrackNext, zBtnNext] then Position := Position + EffectiveWindow; end; zTrackPrev: begin Pt := MousePos; if GetZone(Pt.X, Pt.Y) in [zTrackPrev, zBtnPrev] then Position := Position - EffectiveWindow; end; end; FGenChange := False; end; procedure TCustomRangeBar.UpdateEffectiveWindow; begin if FWindow > 0 then FEffectiveWindow := FWindow else begin if Kind = sbHorizontal then FEffectiveWindow := Width else FEffectiveWindow := Height; end; end; //----------------------------------------------------------------------------// { TCustomGaugeBar } procedure TCustomGaugeBar.AdjustPosition; begin if Position < Min then Position := Min else if Position > Max then Position := Max; end; constructor TCustomGaugeBar.Create(AOwner: TComponent); begin inherited; FLargeChange := 1; FMax := 100; FSmallChange := 1; end; function TCustomGaugeBar.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; begin Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos); if not Result then Position := Position + FSmallChange * WheelDelta div 120; Result := True; end; function TCustomGaugeBar.GetHandleRect: TRect; var Sz, HandleSz: Integer; Horz: Boolean; Pos: Integer; begin Result := GetTrackBoundary; Horz := Kind = sbHorizontal; HandleSz := GetHandleSize; if Horz then Sz := Result.Right - Result.Left else Sz := Result.Bottom - Result.Top; Pos := Round((Position - Min) / (Max - Min) * (Sz - GetHandleSize)); if Horz then begin Inc(Result.Left, Pos); Result.Right := Result.Left + HandleSz; end else begin Inc(Result.Top, Pos); Result.Bottom := Result.Top + HandleSz; end; end; function TCustomGaugeBar.GetHandleSize: Integer; var R: TRect; Sz: Integer; begin Result := HandleSize; if Result = 0 then begin if Kind = sbHorizontal then Result := ClientHeight else Result := ClientWidth; end; R := GetTrackBoundary; if Kind = sbHorizontal then Sz := R.Right - R.Left else Sz := R.Bottom - R.Top; if Sz - Result < 1 then Result := Sz - 1; if Result < 0 then Result := 0; end; procedure TCustomGaugeBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; if FDragZone = zHandle then begin StopDragTracking; FPosBeforeDrag := Position; end; end; procedure TCustomGaugeBar.MouseMove(Shift: TShiftState; X, Y: Integer); var Delta: Single; R: TRect; ClientSz: Integer; begin inherited; if FDragZone = zHandle then begin if Kind = sbHorizontal then Delta := X - FStored.X else Delta := Y - FStored.Y; R := GetTrackBoundary; if Kind = sbHorizontal then ClientSz := R.Right - R.Left else ClientSz := R.Bottom - R.Top; Delta := Delta * (Max - Min) / (ClientSz - GetHandleSize); FGenChange := True; Position := Round(FPosBeforeDrag + Delta); FGenChange := False; end; end; procedure TCustomGaugeBar.SetHandleSize(Value: Integer); begin if Value < 0 then Value := 0; if Value <> FHandleSize then begin FHandleSize := Value; Invalidate; end; end; procedure TCustomGaugeBar.SetLargeChange(Value: Integer); begin if Value < 1 then Value := 1; FLargeChange := Value; end; procedure TCustomGaugeBar.SetMax(Value: Integer); begin if (Value <= FMin) and not (csLoading in ComponentState) then Value := FMin + 1; if Value <> FMax then begin FMax := Value; AdjustPosition; Invalidate; end; end; procedure TCustomGaugeBar.SetMin(Value: Integer); begin if (Value >= FMax) and not (csLoading in ComponentState) then Value := FMax - 1; if Value <> FMin then begin FMin := Value; AdjustPosition; Invalidate; end; end; procedure TCustomGaugeBar.SetPosition(Value: Integer); begin if Value < Min then Value := Min else if Value > Max then Value := Max; if Round(FPosition) <> Value then begin FPosition := Value; Invalidate; DoChange; end; end; procedure TCustomGaugeBar.SetSmallChange(Value: Integer); begin if Value < 1 then Value := 1; FSmallChange := Value; end; procedure TCustomGaugeBar.TimerHandler(Sender: TObject); var OldPosition: Single; Pt: TPoint; function MousePos: TPoint; begin Result := ScreenToClient(Mouse.CursorPos); if Result.X < 0 then Result.X := 0; if Result.Y < 0 then Result.Y := 0; if Result.X >= ClientWidth then Result.X := ClientWidth - 1; if Result.Y >= ClientHeight then Result.Y := ClientHeight - 1 end; begin inherited; FGenChange := True; OldPosition := Position; case FDragZone of zBtnPrev: begin Position := Position - SmallChange; if Position = OldPosition then StopDragTracking; end; zBtnNext: begin Position := Position + SmallChange; if Position = OldPosition then StopDragTracking; end; zTrackNext: begin Pt := MousePos; if GetZone(Pt.X, Pt.Y) in [zTrackNext, zBtnNext] then Position := Position + LargeChange; end; zTrackPrev: begin Pt := MousePos; if GetZone(Pt.X, Pt.Y) in [zTrackPrev, zBtnPrev] then Position := Position - LargeChange; end; end; FGenChange := False; end; { TArrowBarAccess } function TArrowBarAccess.GetBackgnd: TRBBackgnd; begin Result := FMaster.Backgnd; end; function TArrowBarAccess.GetButtonSize: Integer; begin Result := FMaster.ButtonSize; end; function TArrowBarAccess.GetColor: TColor; begin Result := FMaster.Color; end; function TArrowBarAccess.GetHandleColor: TColor; begin Result := FMaster.HandleColor; end; function TArrowBarAccess.GetHighLightColor: TColor; begin Result := FMaster.HighLightColor; end; function TArrowBarAccess.GetShadowColor: TColor; begin Result := FMaster.ShadowColor; end; function TArrowBarAccess.GetButtonColor: TColor; begin Result := FMaster.ButtonColor; end; function TArrowBarAccess.GetBorderColor: TColor; begin Result := FMaster.BorderColor; end; function TArrowBarAccess.GetShowArrows: Boolean; begin Result := FMaster.ShowArrows; end; function TArrowBarAccess.GetShowHandleGrip: Boolean; begin Result := FMaster.ShowHandleGrip; end; function TArrowBarAccess.GetStyle: TRBStyle; begin Result := FMaster.Style; end; procedure TArrowBarAccess.SetBackgnd(Value: TRBBackgnd); begin FMaster.Backgnd := Value; if FSlave <> nil then FSlave.Backgnd := Value; end; procedure TArrowBarAccess.SetButtonSize(Value: Integer); begin FMaster.ButtonSize := Value; if FSlave <> nil then FSlave.ButtonSize := Value; end; procedure TArrowBarAccess.SetColor(Value: TColor); begin FMaster.Color := Value; if FSlave <> nil then FSlave.Color := Value; end; procedure TArrowBarAccess.SetHandleColor(Value: TColor); begin FMaster.HandleColor := Value; if FSlave <> nil then FSlave.HandleColor := Value; end; procedure TArrowBarAccess.SetHighLightColor(Value: TColor); begin FMaster.HighLightColor := Value; if FSlave <> nil then FSlave.HighLightColor := Value; end; procedure TArrowBarAccess.SetShadowColor(Value: TColor); begin FMaster.ShadowColor := Value; if FSlave <> nil then FSlave.ShadowColor := Value; end; procedure TArrowBarAccess.SetButtonColor(Value: TColor); begin FMaster.ButtonColor := Value; if FSlave <> nil then FSlave.ButtonColor := Value; end; procedure TArrowBarAccess.SetBorderColor(Value: TColor); begin FMaster.BorderColor := Value; if FSlave <> nil then FSlave.BorderColor := Value; end; procedure TArrowBarAccess.SetShowArrows(Value: Boolean); begin FMaster.ShowArrows := Value; if FSlave <> nil then FSlave.ShowArrows := Value; end; procedure TArrowBarAccess.SetShowHandleGrip(Value: Boolean); begin FMaster.ShowHandleGrip := Value; if FSlave <> nil then FSlave.ShowHandleGrip := Value; end; procedure TArrowBarAccess.SetStyle(Value: TRBStyle); begin FMaster.Style := Value; if FSlave <> nil then FSlave.Style := Value; end; end. |
Added src/graphics32/GR32_Rasterizers.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 | unit GR32_Rasterizers; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson * * Portions created by the Initial Developer are Copyright (C) 2004-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Steffen Binas <steffen.binas@aquasoft.de> * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, {$IFDEF Windows} Windows, {$ENDIF} {$ELSE} Windows, {$ENDIF} Classes, GR32, GR32_Blend; type TAssignColor = procedure(var Dst: TColor32; Src: TColor32) of object; PCombineInfo = ^TCombineInfo; TCombineInfo = record SrcAlpha: Integer; DrawMode: TDrawMode; CombineMode: TCombineMode; CombineCallBack: TPixelCombineEvent; TransparentColor: TColor32; end; type { TRasterizer } { A base class for TCustomBitmap32-specific rasterizers. } TRasterizer = class(TThreadPersistent) private FSampler: TCustomSampler; FSrcAlpha: Integer; FBlendMemEx: TBlendMemEx; FCombineCallBack: TPixelCombineEvent; FAssignColor: TAssignColor; FTransparentColor: TColor32; procedure SetSampler(const Value: TCustomSampler); procedure SetCombineInfo(const CombineInfo: TCombineInfo); procedure AssignColorOpaque(var Dst: TColor32; Src: TColor32); procedure AssignColorBlend(var Dst: TColor32; Src: TColor32); procedure AssignColorCustom(var Dst: TColor32; Src: TColor32); procedure AssignColorTransparent(var Dst: TColor32; Src: TColor32); protected procedure AssignTo(Dst: TPersistent); override; procedure DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); virtual; abstract; property AssignColor: TAssignColor read FAssignColor write FAssignColor; public constructor Create; override; procedure Assign(Source: TPersistent); override; procedure Rasterize(Dst: TCustomBitmap32); overload; procedure Rasterize(Dst: TCustomBitmap32; const DstRect: TRect); overload; procedure Rasterize(Dst: TCustomBitmap32; const DstRect: TRect; const CombineInfo: TCombineInfo); overload; procedure Rasterize(Dst: TCustomBitmap32; const DstRect: TRect; Src: TCustomBitmap32); overload; published property Sampler: TCustomSampler read FSampler write SetSampler; end; TRasterizerClass = class of TRasterizer; { TRegularSamplingRasterizer } { This rasterizer simply picks one sample for each pixel in the output bitmap. } TRegularRasterizer = class(TRasterizer) private FUpdateRowCount: Integer; protected procedure DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); override; public constructor Create; override; published property UpdateRowCount: Integer read FUpdateRowCount write FUpdateRowCount; end; { TSwizzlingRasterizer } { An interesting rasterization method where sample locations are choosen according to a fractal pattern called 'swizzling'. With a slight modification to the algorithm this routine will actually yield the well-known sierpinski triangle fractal. An advantage with this pattern is that it may benefit from local coherency in the sampling method used. } TSwizzlingRasterizer = class(TRasterizer) private FBlockSize: Integer; procedure SetBlockSize(const Value: Integer); protected procedure DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); override; public constructor Create; override; published property BlockSize: Integer read FBlockSize write SetBlockSize default 3; end; { TProgressiveRasterizer } { This class will perform rasterization in a progressive manner. It performs subsampling with a block size of 2^n and will successively decrease n in each iteration until n equals zero. } TProgressiveRasterizer = class(TRasterizer) private FSteps: Integer; FUpdateRows: Boolean; procedure SetSteps(const Value: Integer); procedure SetUpdateRows(const Value: Boolean); protected procedure DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); override; public constructor Create; override; published property Steps: Integer read FSteps write SetSteps default 4; property UpdateRows: Boolean read FUpdateRows write SetUpdateRows default True; end; { TTesseralRasterizer } { This is a recursive rasterization method. It uses a divide-and-conquer scheme to subdivide blocks vertically and horizontally into smaller blocks. } TTesseralRasterizer = class(TRasterizer) protected procedure DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); override; end; { TContourRasterizer } TContourRasterizer = class(TRasterizer) protected procedure DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); override; end; { TMultithreadedRegularRasterizer } TMultithreadedRegularRasterizer = class(TRasterizer) protected procedure DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); override; end; { Auxiliary routines } function CombineInfo(Bitmap: TCustomBitmap32): TCombineInfo; const DEFAULT_COMBINE_INFO: TCombineInfo = ( SrcAlpha: $FF; DrawMode: dmOpaque; CombineMode: cmBlend; CombineCallBack: nil; TransparentColor: clBlack32; ); var DefaultRasterizerClass: TRasterizerClass = TRegularRasterizer; NumberOfProcessors: Integer = 1; implementation uses Math, SysUtils, GR32_Math, GR32_System, GR32_LowLevel, GR32_Resamplers, GR32_Containers, GR32_OrdinalMaps; type TCustomBitmap32Access = class(TCustomBitmap32); TLineRasterizerData = record ScanLine: Integer; end; PLineRasterizerData = ^TLineRasterizerData; TScanLineRasterizerThread = class(TThread) protected Data: PLineRasterizerData; DstRect: TRect; Dst: TCustomBitmap32; GetSample: TGetSampleInt; AssignColor: TAssignColor; procedure Execute; override; end; function CombineInfo(Bitmap: TCustomBitmap32): TCombineInfo; begin with Result do begin SrcAlpha := Bitmap.MasterAlpha; DrawMode := Bitmap.DrawMode; CombineMode := Bitmap.CombineMode; CombineCallBack := Bitmap.OnPixelCombine; if (DrawMode = dmCustom) and not Assigned(CombineCallBack) then DrawMode := dmOpaque; TransparentColor := Bitmap.OuterColor; end; end; { TRasterizer } procedure TRasterizer.AssignColorBlend(var Dst: TColor32; Src: TColor32); begin FBlendMemEx(Src, Dst, FSrcAlpha); EMMS; end; procedure TRasterizer.AssignColorOpaque(var Dst: TColor32; Src: TColor32); begin Dst := Src; end; procedure TRasterizer.AssignColorCustom(var Dst: TColor32; Src: TColor32); begin FCombineCallBack(Src, Dst, FSrcAlpha); end; procedure TRasterizer.AssignColorTransparent(var Dst: TColor32; Src: TColor32); begin if Src <> FTransparentColor then Dst := Src; end; procedure TRasterizer.AssignTo(Dst: TPersistent); begin if Dst is TRasterizer then SmartAssign(Self, Dst) else inherited; end; procedure TRasterizer.Rasterize(Dst: TCustomBitmap32; const DstRect: TRect; Src: TCustomBitmap32); begin Rasterize(Dst, DstRect, CombineInfo(Src)); end; procedure TRasterizer.Rasterize(Dst: TCustomBitmap32; const DstRect: TRect; const CombineInfo: TCombineInfo); begin SetCombineInfo(CombineInfo); Rasterize(Dst, DstRect); end; procedure TRasterizer.SetCombineInfo(const CombineInfo: TCombineInfo); begin with CombineInfo do begin FTransparentColor := TransparentColor; FSrcAlpha := SrcAlpha; FBlendMemEx := BLEND_MEM_EX[CombineMode]^; FCombineCallBack := CombineCallBack; case DrawMode of dmOpaque: FAssignColor := AssignColorOpaque; dmBlend: FAssignColor := AssignColorBlend; dmTransparent: FAssignColor := AssignColorTransparent; else if Assigned(FCombineCallback) then FAssignColor := AssignColorCustom else FAssignColor := AssignColorBlend; end; end; end; procedure TRasterizer.Rasterize(Dst: TCustomBitmap32; const DstRect: TRect); var UpdateCount: Integer; R: TRect; begin UpdateCount := TCustomBitmap32Access(Dst).UpdateCount; if Assigned(FSampler) then begin FSampler.PrepareSampling; IntersectRect(R, DstRect, Dst.BoundsRect); if FSampler.HasBounds then IntersectRect(R, DstRect, MakeRect(FSampler.GetSampleBounds, rrOutside)); try DoRasterize(Dst, R); finally while TCustomBitmap32Access(Dst).UpdateCount > UpdateCount do TCustomBitmap32Access(Dst).EndUpdate; FSampler.FinalizeSampling; end; end; end; procedure TRasterizer.SetSampler(const Value: TCustomSampler); begin if FSampler <> Value then begin FSampler := Value; Changed; end; end; procedure TRasterizer.Rasterize(Dst: TCustomBitmap32); begin Rasterize(Dst, Dst.BoundsRect); end; constructor TRasterizer.Create; begin inherited; SetCombineInfo(DEFAULT_COMBINE_INFO); end; procedure TRasterizer.Assign(Source: TPersistent); begin BeginUpdate; try if Source is TCustomBitmap32 then SetCombineInfo(CombineInfo(TCustomBitmap32(Source))) else inherited; finally EndUpdate; Changed; end; end; { TRegularRasterizer } constructor TRegularRasterizer.Create; begin inherited; FUpdateRowCount := 0; end; procedure TRegularRasterizer.DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); var I, J, UpdateCount: Integer; P: PColor32; GetSample: TGetSampleInt; begin GetSample := FSampler.GetSampleInt; UpdateCount := 0; for J := DstRect.Top to DstRect.Bottom - 1 do begin P := @Dst.Bits[DstRect.Left + J * Dst.Width]; for I := DstRect.Left to DstRect.Right - 1 do begin AssignColor(P^, GetSample(I, J)); Inc(P); end; Inc(UpdateCount); if UpdateCount = FUpdateRowCount then begin Dst.Changed(Rect(DstRect.Left, J - UpdateCount, DstRect.Right, J)); UpdateCount := 0; end; end; with DstRect do Dst.Changed(Rect(Left, Bottom - UpdateCount - 1, Right, Bottom)); end; { TSwizzlingRasterizer } constructor TSwizzlingRasterizer.Create; begin inherited; FBlockSize := 3; end; procedure TSwizzlingRasterizer.DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); var I, L, T, W, H, Size, RowSize, D: Integer; P1, P2, PBlock: TPoint; GetSample: TGetSampleInt; ForwardBuffer: array of Integer; function GetDstCoord(P: TPoint): TPoint; var XI, YI: Integer; begin Result := P; Inc(Result.X); Inc(Result.Y); XI := ForwardBuffer[Result.X]; YI := ForwardBuffer[Result.Y]; if XI <= YI then Dec(Result.Y, 1 shl XI) else Dec(Result.X, 1 shl (YI + 1)); if Result.Y >= H then begin Result.Y := P.Y + 1 shl YI; Result.X := P.X; Result := GetDstCoord(Result); end; if Result.X >= W then begin Result.X := P.X + 1 shl XI; Result.Y := P.Y; Result := GetDstCoord(Result); end; end; begin W := DstRect.Right - DstRect.Left; H := DstRect.Bottom - DstRect.Top; L := DstRect.Left; T := DstRect.Top; Size := NextPowerOf2(Max(W, H)); SetLength(ForwardBuffer, Size + 1); I := 2; while I <= Size do begin ForwardBuffer[I] := ForwardBuffer[I shr 1] + 1; Inc(I, 2); end; Size := W * H - 1; GetSample := FSampler.GetSampleInt; D := 1 shl FBlockSize; PBlock := Point(L + D, T + D); P1 := Point(-1, 0); RowSize := Dst.Width; for I := 0 to Size do begin P1 := GetDstCoord(P1); P2.X := L + P1.X; P2.Y := T + P1.Y; AssignColor(Dst.Bits[P2.X + P2.Y * RowSize], GetSample(P2.X, P2.Y)); // Invalidate the current block if (P2.X >= PBlock.X) or (P2.Y >= PBlock.Y) then begin Dst.Changed(Rect(PBlock.X - D, PBlock.Y - D, PBlock.X, PBlock.Y)); PBlock.X := P2.X + D; PBlock.Y := P2.Y + D; end; end; Dst.Changed(Rect(PBlock.X - D, PBlock.Y - D, PBlock.X, PBlock.Y)); end; procedure TSwizzlingRasterizer.SetBlockSize(const Value: Integer); begin if FBlockSize <> Value then begin FBlockSize := Value; Changed; end; end; { TProgressiveRasterizer } constructor TProgressiveRasterizer.Create; begin inherited; FSteps := 4; FUpdateRows := True; end; {$DEFINE UseInternalFill} procedure TProgressiveRasterizer.DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); var I, J, Shift, W, H, B, Wk, Hk, X, Y: Integer; DoUpdate: Boolean; OnChanged: TAreaChangedEvent; Step: Integer; GetSample: TGetSampleInt; {$IFDEF UseInternalFill} Bits: PColor32Array; procedure IntFillRect(X1, Y1, X2, Y2: Integer; C: TColor32); var Y: Integer; P: PColor32Array; begin for Y := Y1 to Y2 - 1 do begin P := Pointer(@Bits[Y * W]); FillLongword(P[X1], X2 - X1, C); end; end; {$ENDIF} begin GetSample := FSampler.GetSampleInt; OnChanged := Dst.OnAreaChanged; {$IFDEF UseInternalFill} Bits := Dst.Bits; {$ENDIF} DoUpdate := (TCustomBitmap32Access(Dst).UpdateCount = 0) and Assigned(OnChanged); W := DstRect.Right - DstRect.Left; H := DstRect.Bottom - DstRect.Top; J := DstRect.Top; Step := 1 shl FSteps; while J < DstRect.Bottom do begin I := DstRect.Left; B := Min(J + Step, DstRect.Bottom); while I < DstRect.Right - Step do begin {$IFDEF UseInternalFill} IntFillRect(I, J, I + Step, B, GetSample(I, J)); {$ELSE} Dst.FillRect(I, J, I + Step, B, GetSample(I, J)); {$ENDIF} Inc(I, Step); end; {$IFDEF UseInternalFill} IntFillRect(I, J, DstRect.Right, B, GetSample(I, J)); if DoUpdate and FUpdateRows then OnChanged(Dst, Rect(DstRect.Left, J, DstRect.Right, B), AREAINFO_RECT); {$ELSE} Dst.FillRect(I, J, DstRect.Right, B, GetSample(I, J)); {$ENDIF} Inc(J, Step); end; if DoUpdate and (not FUpdateRows) then OnChanged(Dst, DstRect, AREAINFO_RECT); Shift := FSteps; while Step > 1 do begin Dec(Shift); Step := Step div 2; Wk := W div Step - 1; Hk := H div Step; for J := 0 to Hk do begin Y := DstRect.Top + J shl Shift; B := Min(Y + Step, DstRect.Bottom); if Odd(J) then for I := 0 to Wk do begin X := DstRect.Left + I shl Shift; {$IFDEF UseInternalFill} IntFillRect(X, Y, X + Step, B, GetSample(X, Y)); {$ELSE} Dst.FillRect(X, Y, X + Step, B, GetSample(X, Y)); {$ENDIF} end else for I := 0 to Wk do if Odd(I) then begin X := DstRect.Left + I shl Shift; {$IFDEF UseInternalFill} IntFillRect(X, Y, X + Step, B, GetSample(X, Y)); {$ELSE} Dst.FillRect(X, Y, X + Step, B, GetSample(X, Y)); {$ENDIF} end; X := DstRect.Left + Wk shl Shift; {$IFDEF UseInternalFill} IntFillRect(X, Y, DstRect.Right, B, GetSample(X, Y)); if FUpdateRows and DoUpdate then OnChanged(Dst, Rect(DstRect.Left, Y, DstRect.Right, B), AREAINFO_RECT); {$ELSE} Dst.FillRect(X, Y, DstRect.Right, B, GetSample(X, Y)); {$ENDIF} end; if DoUpdate and (not FUpdateRows) then OnChanged(Dst, DstRect, AREAINFO_RECT); end; end; procedure TProgressiveRasterizer.SetSteps(const Value: Integer); begin if FSteps <> Value then begin FSteps := Value; Changed; end; end; procedure TProgressiveRasterizer.SetUpdateRows(const Value: Boolean); begin if FUpdateRows <> Value then begin FUpdateRows := Value; Changed; end; end; { TTesseralRasterizer } procedure TTesseralRasterizer.DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); var W, H, I: Integer; GetSample: TGetSampleInt; procedure SplitHorizontal(X, Y, Width, Height: Integer); forward; procedure SplitVertical(X, Y, Width, Height: Integer); var HalfWidth, X2, I: Integer; begin HalfWidth := Width div 2; if HalfWidth > 0 then begin X2 := X + HalfWidth; for I := Y + 1 to Y + Height - 1 do AssignColor(Dst.PixelPtr[X2, I]^, GetSample(X2, I)); Dst.Changed(Rect(X2, Y, X2 + 1, Y + Height)); SplitHorizontal(X, Y, HalfWidth, Height); SplitHorizontal(X2, Y, Width - HalfWidth, Height); end; end; procedure SplitHorizontal(X, Y, Width, Height: Integer); var HalfHeight, Y2, I: Integer; begin HalfHeight := Height div 2; if HalfHeight > 0 then begin Y2 := Y + HalfHeight; for I := X + 1 to X + Width - 1 do AssignColor(Dst.PixelPtr[I, Y2]^, GetSample(I, Y2)); Dst.Changed(Rect(X, Y2, X + Width, Y2 + 1)); SplitVertical(X, Y, Width, HalfHeight); SplitVertical(X, Y2, Width, Height - HalfHeight); end; end; begin GetSample := FSampler.GetSampleInt; with DstRect do begin W := Right - Left; H := Bottom - Top; for I := Left to Right - 1 do AssignColor(Dst.PixelPtr[I, Top]^, GetSample(I, Top)); Dst.Changed(Rect(Left, Top, Right, Top + 1)); for I := Top to Bottom - 1 do AssignColor(Dst.PixelPtr[Left, I]^, GetSample(Left, I)); Dst.Changed(Rect(Left, Top, Left + 1, Bottom)); if W > H then SplitVertical(Left, Top, W, H) else SplitHorizontal(Left, Top, W, H); end; end; { TContourRasterizer } procedure InflateRect(const P: TPoint; var R: TRect); begin if P.X < R.Left then R.Left := P.X; if P.Y < R.Top then R.Top := P.Y; if P.X >= R.Right then R.Right := P.X + 1; if P.Y >= R.Bottom then R.Bottom := P.Y + 1; end; procedure TContourRasterizer.DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); type TDirection = (North, East, South, West); var I, J, D, Diff: Integer; C, CLast: TColor32; P, PLast: TPoint; GetSample: TGetSampleInt; NewDir, Dir: TDirection; Visited: TBooleanMap; UpdateRect: TRect; const LEFT: array[TDirection] of TDirection = (West, North, East, South); RIGHT: array[TDirection] of TDirection = (East, South, West, North); COORDS: array[TDirection] of TPoint = ((X: 0; Y: -1), (X: 1; Y: 0), (X: 0; Y: 1), (X: -1; Y: 0)); label MainLoop; begin GetSample := FSampler.GetSampleInt; Visited := TBooleanMap.Create; try with DstRect do Visited.SetSize(Right - Left, Bottom - Top); I := 0; J := 0; Dir := East; NewDir := East; PLast := Point(DstRect.Left, DstRect.Top); CLast := GetSample(PLast.X, PLast.Y); AssignColor(Dst.PixelPtr[PLast.X, PLast.Y]^, CLast); UpdateRect := Rect(PLast.X, PLast.Y, PLast.X + 1, PLast.Y + 1); while True do begin MainLoop: Diff := MaxInt; // forward with COORDS[Dir] do P := Point(PLast.X + X, PLast.Y + Y); if PtInRect(DstRect, P) and (not Visited[P.X, P.Y]) then begin C := GetSample(P.X, P.Y); Diff := Intensity(ColorSub(C, CLast)); EMMS; NewDir := Dir; AssignColor(Dst.PixelPtr[P.X, P.Y]^, C); Visited[P.X - DstRect.Left, P.Y - DstRect.Top] := True; InflateRect(P, UpdateRect); end; // left with COORDS[LEFT[Dir]] do P := Point(PLast.X + X, PLast.Y + Y); if PtInRect(DstRect, P) and (not Visited[P.X, P.Y]) then begin C := GetSample(P.X, P.Y); D := Intensity(ColorSub(C, CLast)); EMMS; if D < Diff then begin NewDir := LEFT[Dir]; Diff := D; end; AssignColor(Dst.PixelPtr[P.X, P.Y]^, C); Visited[P.X - DstRect.Left, P.Y - DstRect.Top] := True; InflateRect(P, UpdateRect); end; // right with COORDS[RIGHT[Dir]] do P := Point(PLast.X + X, PLast.Y + Y); if PtInRect(DstRect, P) and (not Visited[P.X, P.Y]) then begin C := GetSample(P.X, P.Y); D := Intensity(ColorSub(C, CLast)); EMMS; if D < Diff then begin NewDir := RIGHT[Dir]; Diff := D; end; AssignColor(Dst.PixelPtr[P.X, P.Y]^, C); Visited[P.X - DstRect.Left, P.Y - DstRect.Top] := True; InflateRect(P, UpdateRect); end; if Diff = MaxInt then begin Dst.Changed(UpdateRect); while J < Visited.Height do begin while I < Visited.Width do begin if not Visited[I, J] then begin Visited[I, J] := True; PLast := Point(DstRect.Left + I, DstRect.Top + J); CLast := GetSample(PLast.X, PLast.Y); AssignColor(Dst.PixelPtr[PLast.X, PLast.Y]^, CLast); UpdateRect := Rect(PLast.X, PLast.Y, PLast.X + 1, PLast.Y + 1); goto MainLoop; end; Inc(I); end; I := 0; Inc(J); end; Break; end; Dir := NewDir; with COORDS[Dir] do PLast := Point(PLast.X + X, PLast.Y + Y); CLast := Dst[PLast.X, PLast.Y]; end; finally Visited.Free; end; end; { TMultithreadedRegularRasterizer } procedure TMultithreadedRegularRasterizer.DoRasterize(Dst: TCustomBitmap32; DstRect: TRect); var I: Integer; Threads: array of TScanLineRasterizerThread; Data: TLineRasterizerData; function CreateThread: TScanLineRasterizerThread; begin Result := TScanLineRasterizerThread.Create(True); Result.Data := @Data; Result.DstRect := DstRect; Result.GetSample := Sampler.GetSampleInt; Result.AssignColor := AssignColor; Result.Dst := Dst; {$IFDEF USETHREADRESUME} Result.Resume; {$ELSE} Result.Start; {$ENDIF} end; begin Data.ScanLine := DstRect.Top - 1; { Start Threads } SetLength(Threads, NumberOfProcessors); try for I := 0 to NumberOfProcessors - 1 do Threads[I] := CreateThread; { Wait for Threads to be ready } for I := 0 to High(Threads) do begin Threads[I].WaitFor; Threads[I].Free; end; finally Dst.Changed(DstRect); end; end; { TLineRasterizerThread } procedure TScanLineRasterizerThread.Execute; var ScanLine: Integer; I: Integer; P: PColor32; begin ScanLine := InterlockedIncrement(Data^.ScanLine); while ScanLine < DstRect.Bottom do begin P := @Dst.Bits[DstRect.Left + ScanLine * Dst.Width]; for I := DstRect.Left to DstRect.Right - 1 do begin AssignColor(P^, GetSample(I, ScanLine)); Inc(P); end; ScanLine := InterlockedIncrement(Data^.ScanLine); end; end; initialization NumberOfProcessors := GetProcessorCount; {$IFDEF USEMULTITHREADING} if NumberOfProcessors > 1 then DefaultRasterizerClass := TMultithreadedRegularRasterizer; {$ENDIF} end. |
Added src/graphics32/GR32_Reg.dcr.
cannot compute difference between binary files
Added src/graphics32/GR32_Reg.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | unit GR32_Reg; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Classes, TypInfo, {$IFDEF FPC} LCLIntf, LResources, LazIDEIntf, PropEdits, ComponentEditors {$ELSE} DesignIntf {$ENDIF}; procedure Register; implementation uses GR32, GR32_Dsgn_Color, GR32_Dsgn_Bitmap, GR32_Dsgn_Misc, GR32_Image, {$IFDEF Windows} GR32_ExtImage, {$ENDIF} GR32_Layers, GR32_RangeBars, GR32_ColorPicker, GR32_ColorSwatch, GR32_Resamplers; { Registration } procedure Register; begin RegisterComponents('Graphics32', [TPaintBox32, TImage32, TBitmap32List, TRangeBar, TGaugeBar, TImgView32{$IFDEF Windows}, TSyntheticImage32{$ENDIF}, TColorPickerComponent, TColorPickerRGBA, TColorPickerHS, TColorPickerHSV, TColorPickerGTK, {$IFDEF COMPILER2010_UP} TColor32Dialog,{$ENDIF} TColorSwatch]); RegisterPropertyEditor(TypeInfo(TColor32), nil, '', TColor32Property); RegisterPropertyEditor(TypeInfo(TBitmap32), nil, '', TBitmap32Property); RegisterComponentEditor(TCustomImage32, TImage32Editor); RegisterPropertyEditor(TypeInfo(string), TBitmap32, 'ResamplerClassName', nil); RegisterPropertyEditor(TypeInfo(TCustomResampler), TBitmap32, 'Resampler', TResamplerClassProperty); RegisterPropertyEditor(TypeInfo(string), TKernelResampler, 'KernelClassName', nil); RegisterPropertyEditor(TypeInfo(TCustomKernel), TKernelResampler, 'Kernel', TKernelClassProperty); end; initialization {$IFDEF FPC} {$i GR32_reg.lrs} {$ENDIF} end. |
Added src/graphics32/GR32_RepaintOpt.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | unit GR32_RepaintOpt; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Repaint Optimizer Extension for Graphics32 * * The Initial Developer of the Original Code is * Andre Beckedorf - metaException * Andre@metaException.de * * Portions created by the Initial Developer are Copyright (C) 2005-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, {$ELSE} Types, Windows, {$ENDIF} Classes, SysUtils, GR32, GR32_Containers, GR32_Layers; type { TCustomRepaintOptimizer } TCustomRepaintOptimizer = class private FEnabled: Boolean; FLayerCollections: TList; FInvalidRects: TRectList; FBuffer: TBitmap32; protected function GetEnabled: Boolean; virtual; procedure SetEnabled(const Value: Boolean); virtual; property LayerCollections: TList read FLayerCollections write FLayerCollections; property Buffer: TBitmap32 read FBuffer write FBuffer; property InvalidRects: TRectList read FInvalidRects write FInvalidRects; // LayerCollection handler procedure LayerCollectionNotifyHandler(Sender: TLayerCollection; Action: TLayerListNotification; Layer: TCustomLayer; Index: Integer); virtual; abstract; public constructor Create(Buffer: TBitmap32; InvalidRects: TRectList); virtual; destructor Destroy; override; procedure RegisterLayerCollection(Layers: TLayerCollection); virtual; procedure UnregisterLayerCollection(Layers: TLayerCollection); virtual; procedure BeginPaint; virtual; procedure EndPaint; virtual; procedure BeginPaintBuffer; virtual; procedure EndPaintBuffer; virtual; procedure Reset; virtual; abstract; function UpdatesAvailable: Boolean; virtual; abstract; procedure PerformOptimization; virtual; abstract; // handlers procedure AreaUpdateHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); virtual; abstract; procedure LayerUpdateHandler(Sender: TObject; Layer: TCustomLayer); virtual; abstract; procedure BufferResizedHandler(const NewWidth, NewHeight: Integer); virtual; abstract; property Enabled: Boolean read GetEnabled write SetEnabled; end; TCustomRepaintOptimizerClass = class of TCustomRepaintOptimizer; // differs from InflateRect in the way that it does also handle negative rects procedure InflateArea(var Area: TRect; Dx, Dy: Integer); implementation procedure InflateArea(var Area: TRect; Dx, Dy: Integer); begin if Area.Left > Area.Right then Dx := -Dx; if Area.Top > Area.Bottom then Dy := -Dy; Dec(Area.Left, Dx); Dec(Area.Top, Dy); Inc(Area.Right, Dx); Inc(Area.Bottom, Dy); end; type TLayerCollectionAccess = class(TLayerCollection); { TCustomRepaintManager } constructor TCustomRepaintOptimizer.Create(Buffer: TBitmap32; InvalidRects: TRectList); begin FLayerCollections := TList.Create; FInvalidRects := InvalidRects; FBuffer := Buffer; end; destructor TCustomRepaintOptimizer.Destroy; var I: Integer; begin for I := 0 to FLayerCollections.Count - 1 do UnregisterLayerCollection(TLayerCollection(FLayerCollections[I])); FLayerCollections.Free; inherited; end; function TCustomRepaintOptimizer.GetEnabled: Boolean; begin Result := FEnabled; end; procedure TCustomRepaintOptimizer.SetEnabled(const Value: Boolean); begin FEnabled := Value; end; procedure TCustomRepaintOptimizer.RegisterLayerCollection(Layers: TLayerCollection); begin if FLayerCollections.IndexOf(Layers) = -1 then begin FLayerCollections.Add(Layers); TLayerCollectionAccess(Layers).OnListNotify := LayerCollectionNotifyHandler; end; end; procedure TCustomRepaintOptimizer.UnregisterLayerCollection(Layers: TLayerCollection); begin TLayerCollectionAccess(Layers).OnListNotify := nil; FLayerCollections.Remove(Layers); end; procedure TCustomRepaintOptimizer.BeginPaint; begin // do nothing by default end; procedure TCustomRepaintOptimizer.EndPaint; begin // do nothing by default end; procedure TCustomRepaintOptimizer.BeginPaintBuffer; begin // do nothing by default end; procedure TCustomRepaintOptimizer.EndPaintBuffer; begin // do nothing by default end; end. |
Added src/graphics32/GR32_Resamplers.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 | unit GR32_Resamplers; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developers of the Original Code is * Mattias Andersson <mattias@centaurix.com> * (parts of this unit were taken from GR32_Transforms.pas by Alex A. Denisov) * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Michael Hansen <dyster_tid@hotmail.com> * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} {$IFNDEF FPC} {-$IFDEF USE_3DNOW} {$ENDIF} uses {$IFDEF FPC} LCLIntf, {$ELSE} Windows, Types, {$ENDIF} Classes, SysUtils, GR32, GR32_Transforms, GR32_Containers, GR32_OrdinalMaps, GR32_Blend; procedure BlockTransfer( Dst: TCustomBitmap32; DstX: Integer; DstY: Integer; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent = nil); procedure BlockTransferX( Dst: TCustomBitmap32; DstX, DstY: TFixed; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent = nil); procedure StretchTransfer( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; Resampler: TCustomResampler; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent = nil); procedure BlendTransfer( Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect; SrcF: TCustomBitmap32; SrcRectF: TRect; SrcB: TCustomBitmap32; SrcRectB: TRect; BlendCallback: TBlendReg); overload; procedure BlendTransfer( Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect; SrcF: TCustomBitmap32; SrcRectF: TRect; SrcB: TCustomBitmap32; SrcRectB: TRect; BlendCallback: TBlendRegEx; MasterAlpha: Integer); overload; const MAX_KERNEL_WIDTH = 16; type PKernelEntry = ^TKernelEntry; TKernelEntry = array [-MAX_KERNEL_WIDTH..MAX_KERNEL_WIDTH] of Integer; TArrayOfKernelEntry = array of TArrayOfInteger; PKernelEntryArray = ^TKernelEntryArray; TKernelEntryArray = array [0..0] of TArrayOfInteger; TFilterMethod = function(Value: TFloat): TFloat of object; EBitmapException = class(Exception); ESrcInvalidException = class(Exception); ENestedException = class(Exception); TGetSampleInt = function(X, Y: Integer): TColor32 of object; TGetSampleFloat = function(X, Y: TFloat): TColor32 of object; TGetSampleFixed = function(X, Y: TFixed): TColor32 of object; { TCustomKernel } TCustomKernel = class(TPersistent) protected FObserver: TNotifiablePersistent; protected procedure AssignTo(Dst: TPersistent); override; function RangeCheck: Boolean; virtual; public constructor Create; virtual; procedure Changed; function Filter(Value: TFloat): TFloat; virtual; abstract; function GetWidth: TFloat; virtual; abstract; property Observer: TNotifiablePersistent read FObserver; end; TCustomKernelClass = class of TCustomKernel; { TBoxKernel } TBoxKernel = class(TCustomKernel) public function Filter(Value: TFloat): TFloat; override; function GetWidth: TFloat; override; end; { TLinearKernel } TLinearKernel = class(TCustomKernel) public function Filter(Value: TFloat): TFloat; override; function GetWidth: TFloat; override; end; { TCosineKernel } TCosineKernel = class(TCustomKernel) public function Filter(Value: TFloat): TFloat; override; function GetWidth: TFloat; override; end; { TSplineKernel } TSplineKernel = class(TCustomKernel) protected function RangeCheck: Boolean; override; public function Filter(Value: TFloat): TFloat; override; function GetWidth: TFloat; override; end; { TMitchellKernel } TMitchellKernel = class(TCustomKernel) protected function RangeCheck: Boolean; override; public function Filter(Value: TFloat): TFloat; override; function GetWidth: TFloat; override; end; { TCubicKernel } TCubicKernel = class(TCustomKernel) private FCoeff: TFloat; procedure SetCoeff(const Value: TFloat); protected function RangeCheck: Boolean; override; public constructor Create; override; function Filter(Value: TFloat): TFloat; override; function GetWidth: TFloat; override; published property Coeff: TFloat read FCoeff write SetCoeff; end; { THermiteKernel } THermiteKernel = class(TCustomKernel) private FBias: TFloat; FTension: TFloat; procedure SetBias(const Value: TFloat); procedure SetTension(const Value: TFloat); protected function RangeCheck: Boolean; override; public constructor Create; override; function Filter(Value: TFloat): TFloat; override; function GetWidth: TFloat; override; published property Bias: TFloat read FBias write SetBias; property Tension: TFloat read FTension write SetTension; end; { TWindowedSincKernel } TWindowedSincKernel = class(TCustomKernel) private FWidth : TFloat; FWidthReciprocal : TFloat; protected function RangeCheck: Boolean; override; function Window(Value: TFloat): TFloat; virtual; abstract; public constructor Create; override; function Filter(Value: TFloat): TFloat; override; procedure SetWidth(Value: TFloat); function GetWidth: TFloat; override; property WidthReciprocal : TFloat read FWidthReciprocal; published property Width: TFloat read FWidth write SetWidth; end; { TAlbrecht-Kernel } TAlbrechtKernel = class(TWindowedSincKernel) private FTerms: Integer; FCoefPointer : Array [0..11] of Double; procedure SetTerms(Value : Integer); protected function Window(Value: TFloat): TFloat; override; public constructor Create; override; published property Terms: Integer read FTerms write SetTerms; end; { TLanczosKernel } TLanczosKernel = class(TWindowedSincKernel) protected function Window(Value: TFloat): TFloat; override; public end; { TGaussianKernel } TGaussianKernel = class(TWindowedSincKernel) private FSigma: TFloat; FSigmaReciprocalLn2: TFloat; procedure SetSigma(const Value: TFloat); protected function Window(Value: TFloat): TFloat; override; public constructor Create; override; published property Sigma: TFloat read FSigma write SetSigma; end; { TBlackmanKernel } TBlackmanKernel = class(TWindowedSincKernel) protected function Window(Value: TFloat): TFloat; override; end; { THannKernel } THannKernel = class(TWindowedSincKernel) protected function Window(Value: TFloat): TFloat; override; end; { THammingKernel } THammingKernel = class(TWindowedSincKernel) protected function Window(Value: TFloat): TFloat; override; end; { TSinshKernel } TSinshKernel = class(TCustomKernel) private FWidth: TFloat; FCoeff: TFloat; procedure SetCoeff(const Value: TFloat); protected function RangeCheck: Boolean; override; public constructor Create; override; procedure SetWidth(Value: TFloat); function GetWidth: TFloat; override; function Filter(Value: TFloat): TFloat; override; published property Coeff: TFloat read FCoeff write SetCoeff; property Width: TFloat read GetWidth write SetWidth; end; { TNearestResampler } TNearestResampler = class(TCustomResampler) private FGetSampleInt: TGetSampleInt; protected function GetPixelTransparentEdge(X, Y: Integer): TColor32; function GetWidth: TFloat; override; procedure Resample( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); override; public function GetSampleInt(X, Y: Integer): TColor32; override; function GetSampleFixed(X, Y: TFixed): TColor32; override; function GetSampleFloat(X, Y: TFloat): TColor32; override; procedure PrepareSampling; override; end; { TLinearResampler } TLinearResampler = class(TCustomResampler) private FLinearKernel: TLinearKernel; FGetSampleFixed: TGetSampleFixed; protected function GetWidth: TFloat; override; function GetPixelTransparentEdge(X, Y: TFixed): TColor32; procedure Resample( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); override; public constructor Create; override; destructor Destroy; override; function GetSampleFixed(X, Y: TFixed): TColor32; override; function GetSampleFloat(X, Y: TFloat): TColor32; override; procedure PrepareSampling; override; end; { TDraftResampler } TDraftResampler = class(TLinearResampler) protected procedure Resample( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); override; end; { TKernelResampler } { This resampler class will perform resampling by using an arbitrary reconstruction kernel. By using the kmTableNearest and kmTableLinear kernel modes, kernel values are precomputed in a look-up table. This allows GetSample to execute faster for complex kernels. } TKernelMode = (kmDynamic, kmTableNearest, kmTableLinear); TKernelResampler = class(TCustomResampler) private FKernel: TCustomKernel; FKernelMode: TKernelMode; FWeightTable: TIntegerMap; FTableSize: Integer; FOuterColor: TColor32; procedure SetKernel(const Value: TCustomKernel); function GetKernelClassName: string; procedure SetKernelClassName(const Value: string); procedure SetKernelMode(const Value: TKernelMode); procedure SetTableSize(Value: Integer); protected function GetWidth: TFloat; override; public constructor Create; override; destructor Destroy; override; function GetSampleFloat(X, Y: TFloat): TColor32; override; procedure Resample( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); override; procedure PrepareSampling; override; procedure FinalizeSampling; override; published property KernelClassName: string read GetKernelClassName write SetKernelClassName; property Kernel: TCustomKernel read FKernel write SetKernel; property KernelMode: TKernelMode read FKernelMode write SetKernelMode; property TableSize: Integer read FTableSize write SetTableSize; end; { TNestedSampler } TNestedSampler = class(TCustomSampler) private FSampler: TCustomSampler; FGetSampleInt: TGetSampleInt; FGetSampleFixed: TGetSampleFixed; FGetSampleFloat: TGetSampleFloat; procedure SetSampler(const Value: TCustomSampler); protected procedure AssignTo(Dst: TPersistent); override; public constructor Create(ASampler: TCustomSampler); reintroduce; virtual; procedure PrepareSampling; override; procedure FinalizeSampling; override; function HasBounds: Boolean; override; function GetSampleBounds: TFloatRect; override; published property Sampler: TCustomSampler read FSampler write SetSampler; end; { TTransformer } TReverseTransformInt = procedure(DstX, DstY: Integer; out SrcX, SrcY: Integer) of object; TReverseTransformFixed = procedure(DstX, DstY: TFixed; out SrcX, SrcY: TFixed) of object; TReverseTransformFloat = procedure(DstX, DstY: TFloat; out SrcX, SrcY: TFloat) of object; TTransformer = class(TNestedSampler) private FTransformation: TTransformation; FTransformationReverseTransformInt: TReverseTransformInt; FTransformationReverseTransformFixed: TReverseTransformFixed; FTransformationReverseTransformFloat: TReverseTransformFloat; procedure SetTransformation(const Value: TTransformation); public constructor Create(ASampler: TCustomSampler; ATransformation: TTransformation); reintroduce; procedure PrepareSampling; override; function GetSampleInt(X, Y: Integer): TColor32; override; function GetSampleFixed(X, Y: TFixed): TColor32; override; function GetSampleFloat(X, Y: TFloat): TColor32; override; function HasBounds: Boolean; override; function GetSampleBounds: TFloatRect; override; published property Transformation: TTransformation read FTransformation write SetTransformation; end; { TSuperSampler } TSamplingRange = 1..MaxInt; TSuperSampler = class(TNestedSampler) private FSamplingY: TSamplingRange; FSamplingX: TSamplingRange; FDistanceX: TFixed; FDistanceY: TFixed; FOffsetX: TFixed; FOffsetY: TFixed; FScale: TFixed; procedure SetSamplingX(const Value: TSamplingRange); procedure SetSamplingY(const Value: TSamplingRange); public constructor Create(Sampler: TCustomSampler); override; function GetSampleFixed(X, Y: TFixed): TColor32; override; published property SamplingX: TSamplingRange read FSamplingX write SetSamplingX; property SamplingY: TSamplingRange read FSamplingY write SetSamplingY; end; { TAdaptiveSuperSampler } TRecurseProc = function(X, Y, W: TFixed; const C1, C2: TColor32): TColor32 of object; TAdaptiveSuperSampler = class(TNestedSampler) private FMinOffset: TFixed; FLevel: Integer; FTolerance: Integer; procedure SetLevel(const Value: Integer); function DoRecurse(X, Y, Offset: TFixed; const A, B, C, D, E: TColor32): TColor32; function QuadrantColor(const C1, C2: TColor32; X, Y, Offset: TFixed; Proc: TRecurseProc): TColor32; function RecurseAC(X, Y, Offset: TFixed; const A, C: TColor32): TColor32; function RecurseBD(X, Y, Offset: TFixed; const B, D: TColor32): TColor32; protected function CompareColors(C1, C2: TColor32): Boolean; virtual; public constructor Create(Sampler: TCustomSampler); override; function GetSampleFixed(X, Y: TFixed): TColor32; override; published property Level: Integer read FLevel write SetLevel; property Tolerance: Integer read FTolerance write FTolerance; end; { TPatternSampler } TFloatSamplePattern = array of array of TArrayOfFloatPoint; TFixedSamplePattern = array of array of TArrayOfFixedPoint; TPatternSampler = class(TNestedSampler) private FPattern: TFixedSamplePattern; procedure SetPattern(const Value: TFixedSamplePattern); protected WrapProcVert: TWrapProc; public destructor Destroy; override; function GetSampleFixed(X, Y: TFixed): TColor32; override; property Pattern: TFixedSamplePattern read FPattern write SetPattern; end; { Auxiliary record used in accumulation routines } PBufferEntry = ^TBufferEntry; TBufferEntry = record B, G, R, A: Integer; end; { TKernelSampler } TKernelSampler = class(TNestedSampler) private FKernel: TIntegerMap; FStartEntry: TBufferEntry; FCenterX: Integer; FCenterY: Integer; protected procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); virtual; abstract; function ConvertBuffer(var Buffer: TBufferEntry): TColor32; virtual; public constructor Create(ASampler: TCustomSampler); override; destructor Destroy; override; function GetSampleInt(X, Y: Integer): TColor32; override; function GetSampleFixed(X, Y: TFixed): TColor32; override; published property Kernel: TIntegerMap read FKernel write FKernel; property CenterX: Integer read FCenterX write FCenterX; property CenterY: Integer read FCenterY write FCenterY; end; { TConvolver } TConvolver = class(TKernelSampler) protected procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); override; end; { TSelectiveConvolver } TSelectiveConvolver = class(TConvolver) private FRefColor: TColor32; FDelta: Integer; FWeightSum: TBufferEntry; protected procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); override; function ConvertBuffer(var Buffer: TBufferEntry): TColor32; override; public constructor Create(ASampler: TCustomSampler); override; function GetSampleInt(X, Y: Integer): TColor32; override; function GetSampleFixed(X, Y: TFixed): TColor32; override; published property Delta: Integer read FDelta write FDelta; end; { TMorphologicalSampler } TMorphologicalSampler = class(TKernelSampler) protected function ConvertBuffer(var Buffer: TBufferEntry): TColor32; override; end; { TDilater } TDilater = class(TMorphologicalSampler) protected procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); override; end; { TEroder } TEroder = class(TMorphologicalSampler) protected procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); override; public constructor Create(ASampler: TCustomSampler); override; end; { TExpander } TExpander = class(TKernelSampler) protected procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); override; end; { TContracter } TContracter = class(TExpander) private FMaxWeight: TColor32; protected procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); override; public procedure PrepareSampling; override; function GetSampleInt(X, Y: Integer): TColor32; override; function GetSampleFixed(X, Y: TFixed): TColor32; override; end; function CreateJitteredPattern(TileWidth, TileHeight, SamplesX, SamplesY: Integer): TFixedSamplePattern; { Convolution and morphological routines } procedure Convolve(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer); procedure Dilate(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer); procedure Erode(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer); procedure Expand(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer); procedure Contract(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer); { Auxiliary routines for accumulating colors in a buffer } procedure IncBuffer(var Buffer: TBufferEntry; Color: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF} procedure MultiplyBuffer(var Buffer: TBufferEntry; W: Integer); {$IFDEF USEINLINING} inline; {$ENDIF} function BufferToColor32(const Buffer: TBufferEntry; Shift: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} procedure ShrBuffer(var Buffer: TBufferEntry; Shift: Integer); {$IFDEF USEINLINING} inline; {$ENDIF} { Registration routines } procedure RegisterResampler(ResamplerClass: TCustomResamplerClass); procedure RegisterKernel(KernelClass: TCustomKernelClass); var KernelList: TClassList; ResamplerList: TClassList; const EMPTY_ENTRY: TBufferEntry = (B: 0; G: 0; R: 0; A: 0); var BlockAverage: function(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32; Interpolator: function(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32; resourcestring SDstNil = 'Destination bitmap is nil'; SSrcNil = 'Source bitmap is nil'; SSrcInvalid = 'Source rectangle is invalid'; SSamplerNil = 'Nested sampler is nil'; implementation uses GR32_System, GR32_Bindings, GR32_LowLevel, GR32_Rasterizers, GR32_Math, Math; resourcestring RCStrInvalidSrcRect = 'Invalid SrcRect'; const CAlbrecht2 : array [0..1] of Double = (5.383553946707251E-1, 4.616446053292749E-1); CAlbrecht3 : array [0..2] of Double = (3.46100822018625E-1, 4.97340635096738E-1, 1.56558542884637E-1); CAlbrecht4 : array [0..3] of Double = (2.26982412792069E-1, 4.57254070828427E-1, 2.73199027957384E-1, 4.25644884221201E-2); CAlbrecht5 : array [0..4] of Double = (1.48942606015830E-1, 3.86001173639176E-1, 3.40977403214053E-1, 1.139879604246E-1, 1.00908567063414E-2); CAlbrecht6 : array [0..5] of Double = (9.71676200107429E-2, 3.08845222524055E-1, 3.62623371437917E-1, 1.88953325525116E-1, 4.02095714148751E-2, 2.20088908729420E-3); CAlbrecht7 : array [0..6] of Double = (6.39644241143904E-2, 2.39938645993528E-1, 3.50159563238205E-1, 2.47741118970808E-1, 8.54382560558580E-2, 1.23202033692932E-2, 4.37788257917735E-4); CAlbrecht8 : array [0..7] of Double = (4.21072107042137E-2, 1.82076226633776E-1, 3.17713781059942E-1, 2.84438001373442E-1, 1.36762237777383E-1, 3.34038053504025E-2, 3.41677216705768E-3, 8.19649337831348E-5); CAlbrecht9 : array [0..8] of Double = (2.76143731612611E-2, 1.35382228758844E-1, 2.75287234472237E-1, 2.98843335317801E-1, 1.85319330279284E-1, 6.48884482549063E-2, 1.17641910285655E-2, 8.85987580106899E-4, 1.48711469943406E-5); CAlbrecht10: array [0..9] of Double = (1.79908225352538E-2, 9.87959586065210E-2, 2.29883817001211E-1, 2.94113019095183E-1, 2.24338977814325E-1, 1.03248806248099E-1, 2.75674109448523E-2, 3.83958622947123E-3, 2.18971708430106E-4, 2.62981665347889E-6); CAlbrecht11: array [0..10] of Double = (1.18717127796602E-2, 7.19533651951142E-2, 1.87887160922585E-1, 2.75808174097291E-1, 2.48904243244464E-1, 1.41729867200712E-1, 5.02002976228256E-2, 1.04589649084984E-2, 1.13615112741660E-3, 4.96285981703436E-5, 4.34303262685720E-7); type TTransformationAccess = class(TTransformation); TCustomBitmap32Access = class(TCustomBitmap32); TCustomResamplerAccess = class(TCustomResampler); PPointRec = ^TPointRec; TPointRec = record Pos: Integer; Weight: Cardinal; end; TCluster = array of TPointRec; TMappingTable = array of TCluster; TKernelSamplerClass = class of TKernelSampler; { Auxiliary rasterization routine for kernel-based samplers } procedure RasterizeKernelSampler(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer; SamplerClass: TKernelSamplerClass); var Sampler: TKernelSampler; Rasterizer: TRasterizer; begin Rasterizer := DefaultRasterizerClass.Create; try Dst.SetSizeFrom(Src); Sampler := SamplerClass.Create(Src.Resampler); Sampler.Kernel := Kernel; try Rasterizer.Sampler := Sampler; Rasterizer.Rasterize(Dst); finally Sampler.Free; end; finally Rasterizer.Free; end; end; procedure Convolve(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer); begin RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TConvolver); end; procedure Dilate(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer); begin RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TDilater); end; procedure Erode(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer); begin RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TEroder); end; procedure Expand(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer); begin RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TExpander); end; procedure Contract(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer); begin RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TContracter); end; { Auxiliary routines } procedure IncBuffer(var Buffer: TBufferEntry; Color: TColor32); begin with TColor32Entry(Color) do begin Inc(Buffer.B, B); Inc(Buffer.G, G); Inc(Buffer.R, R); Inc(Buffer.A, A); end; end; procedure MultiplyBuffer(var Buffer: TBufferEntry; W: Integer); begin Buffer.B := Buffer.B * W; Buffer.G := Buffer.G * W; Buffer.R := Buffer.R * W; Buffer.A := Buffer.A * W; end; procedure ShrBuffer(var Buffer: TBufferEntry; Shift: Integer); begin Buffer.B := Buffer.B shr Shift; Buffer.G := Buffer.G shr Shift; Buffer.R := Buffer.R shr Shift; Buffer.A := Buffer.A shr Shift; end; function BufferToColor32(const Buffer: TBufferEntry; Shift: Integer): TColor32; begin with TColor32Entry(Result) do begin B := Buffer.B shr Shift; G := Buffer.G shr Shift; R := Buffer.R shr Shift; A := Buffer.A shr Shift; end; end; procedure CheckBitmaps(Dst, Src: TCustomBitmap32); {$IFDEF USEINLINING}inline;{$ENDIF} begin if not Assigned(Dst) then raise EBitmapException.Create(SDstNil); if not Assigned(Src) then raise EBitmapException.Create(SSrcNil); end; procedure BlendBlock( Dst: TCustomBitmap32; DstRect: TRect; Src: TCustomBitmap32; SrcX, SrcY: Integer; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); var SrcP, DstP: PColor32; SP, DP: PColor32; MC: TColor32; W, I, DstY: Integer; BlendLine: TBlendLine; BlendLineEx: TBlendLineEx; begin { Internal routine } W := DstRect.Right - DstRect.Left; SrcP := Src.PixelPtr[SrcX, SrcY]; DstP := Dst.PixelPtr[DstRect.Left, DstRect.Top]; case CombineOp of dmOpaque: begin for DstY := DstRect.Top to DstRect.Bottom - 1 do begin //Move(SrcP^, DstP^, W shl 2); // for FastCode MoveLongWord(SrcP^, DstP^, W); Inc(SrcP, Src.Width); Inc(DstP, Dst.Width); end; end; dmBlend: if Src.MasterAlpha >= 255 then begin BlendLine := BLEND_LINE[Src.CombineMode]^; for DstY := DstRect.Top to DstRect.Bottom - 1 do begin BlendLine(SrcP, DstP, W); Inc(SrcP, Src.Width); Inc(DstP, Dst.Width); end end else begin BlendLineEx := BLEND_LINE_EX[Src.CombineMode]^; for DstY := DstRect.Top to DstRect.Bottom - 1 do begin BlendLineEx(SrcP, DstP, W, Src.MasterAlpha); Inc(SrcP, Src.Width); Inc(DstP, Dst.Width); end end; dmTransparent: begin MC := Src.OuterColor; for DstY := DstRect.Top to DstRect.Bottom - 1 do begin SP := SrcP; DP := DstP; { TODO: Write an optimized routine for fast masked transfers. } for I := 0 to W - 1 do begin if MC <> SP^ then DP^ := SP^; Inc(SP); Inc(DP); end; Inc(SrcP, Src.Width); Inc(DstP, Dst.Width); end; end; else // dmCustom: begin for DstY := DstRect.Top to DstRect.Bottom - 1 do begin SP := SrcP; DP := DstP; for I := 0 to W - 1 do begin CombineCallBack(SP^, DP^, Src.MasterAlpha); Inc(SP); Inc(DP); end; Inc(SrcP, Src.Width); Inc(DstP, Dst.Width); end; end; end; end; procedure BlockTransfer( Dst: TCustomBitmap32; DstX: Integer; DstY: Integer; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); var SrcX, SrcY: Integer; begin CheckBitmaps(Dst, Src); if Dst.Empty or Src.Empty or ((CombineOp = dmBlend) and (Src.MasterAlpha = 0)) then Exit; SrcX := SrcRect.Left; SrcY := SrcRect.Top; GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect); GR32.IntersectRect(SrcRect, SrcRect, Src.BoundsRect); GR32.OffsetRect(SrcRect, DstX - SrcX, DstY - SrcY); GR32.IntersectRect(SrcRect, DstClip, SrcRect); if GR32.IsRectEmpty(SrcRect) then exit; DstClip := SrcRect; GR32.OffsetRect(SrcRect, SrcX - DstX, SrcY - DstY); if not Dst.MeasuringMode then begin try if (CombineOp = dmCustom) and not Assigned(CombineCallBack) then CombineOp := dmOpaque; BlendBlock(Dst, DstClip, Src, SrcRect.Left, SrcRect.Top, CombineOp, CombineCallBack); finally EMMS; end; end; Dst.Changed(DstClip); end; {$WARNINGS OFF} procedure BlockTransferX( Dst: TCustomBitmap32; DstX, DstY: TFixed; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent = nil); type TColor32Array = array [0..1] of TColor32; PColor32Array = ^TColor32Array; var I, Index, SrcW, SrcRectW, SrcRectH, DstW, DstH: Integer; FracX, FracY: Integer; Buffer: array [0..1] of TArrayOfColor32; SrcP, Buf1, Buf2: PColor32Array; DstP: PColor32; C1, C2, C3, C4: TColor32; LW, RW, TW, BW, MA: Integer; DstBounds: TRect; BlendLineEx: TBlendLineEx; BlendMemEx: TBlendMemEx; begin CheckBitmaps(Dst, Src); if Dst.Empty or Src.Empty or ((CombineOp = dmBlend) and (Src.MasterAlpha = 0)) then Exit; SrcRectW := SrcRect.Right - SrcRect.Left - 1; SrcRectH := SrcRect.Bottom - SrcRect.Top - 1; FracX := (DstX and $FFFF) shr 8; FracY := (DstY and $FFFF) shr 8; DstX := DstX div $10000; DstY := DstY div $10000; DstW := Dst.Width; DstH := Dst.Height; MA := Src.MasterAlpha; if (DstX >= DstW) or (DstY >= DstH) or (MA = 0) then Exit; if (DstX + SrcRectW <= 0) or (Dsty + SrcRectH <= 0) then Exit; if DstX < 0 then LW := $FF else LW := FracX xor $FF; if DstY < 0 then TW := $FF else TW := FracY xor $FF; if DstX + SrcRectW >= DstW then RW := $FF else RW := FracX; if DstY + SrcRectH >= DstH then BW := $FF else BW := FracY; DstBounds := Dst.BoundsRect; Dec(DstBounds.Right); Dec(DstBounds.Bottom); GR32.OffsetRect(DstBounds, SrcRect.Left - DstX, SrcRect.Top - DstY); GR32.IntersectRect(SrcRect, SrcRect, DstBounds); if GR32.IsRectEmpty(SrcRect) then Exit; SrcW := Src.Width; SrcRectW := SrcRect.Right - SrcRect.Left; SrcRectH := SrcRect.Bottom - SrcRect.Top; if DstX < 0 then DstX := 0; if DstY < 0 then DstY := 0; if not Dst.MeasuringMode then begin SetLength(Buffer[0], SrcRectW + 1); SetLength(Buffer[1], SrcRectW + 1); BlendLineEx := BLEND_LINE_EX[Src.CombineMode]^; BlendMemEx := BLEND_MEM_EX[Src.CombineMode]^; try SrcP := PColor32Array(Src.PixelPtr[SrcRect.Left, SrcRect.Top - 1]); DstP := Dst.PixelPtr[DstX, DstY]; Buf1 := @Buffer[0][0]; Buf2 := @Buffer[1][0]; if SrcRect.Top > 0 then begin MoveLongWord(SrcP[0], Buf1[0], SrcRectW); CombineLine(@Buf1[1], @Buf1[0], SrcRectW, FracX); if SrcRect.Left > 0 then {$IFDEF HAS_NATIVEINT} C2 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX xor $FF) {$ELSE} C2 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX xor $FF) {$ENDIF} else C2 := SrcP[0]; if SrcRect.Right < SrcW then C4 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX) else C4 := SrcP[SrcRectW - 1]; end; Inc(PColor32(SrcP), SrcW); MoveLongWord(SrcP^, Buf2^, SrcRectW); CombineLine(@Buf2[1], @Buf2[0], SrcRectW, FracX xor $FF); if SrcRect.Left > 0 then {$IFDEF HAS_NATIVEINT} C1 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX) {$ELSE} C1 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX) {$ENDIF} else C1 := SrcP[0]; if SrcRect.Right < SrcW then C3 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX) else C3 := SrcP[SrcRectW - 1]; if SrcRect.Top > 0 then begin BlendMemEx(CombineReg(C1, C2, FracY), DstP^, LW * TW * MA shr 16); CombineLine(@Buf2[0], @Buf1[0], SrcRectW, FracY xor $FF); end else begin BlendMemEx(C1, DstP^, LW * TW * MA shr 16); MoveLongWord(Buf2^, Buf1^, SrcRectW); end; Inc(DstP, 1); BlendLineEx(@Buf1[0], DstP, SrcRectW - 1, TW * MA shr 8); Inc(DstP, SrcRectW - 1); if SrcRect.Top > 0 then BlendMemEx(CombineReg(C3, C4, FracY), DstP^, RW * TW * MA shr 16) else BlendMemEx(C3, DstP^, RW * TW * MA shr 16); Inc(DstP, DstW - SrcRectW); Index := 1; for I := SrcRect.Top to SrcRect.Bottom - 2 do begin Buf1 := @Buffer[Index][0]; Buf2 := @Buffer[Index xor 1][0]; Inc(PColor32(SrcP), SrcW); MoveLongWord(SrcP[0], Buf2^, SrcRectW); // Horizontal translation CombineLine(@Buf2[1], @Buf2[0], SrcRectW, FracX xor $FF); if SrcRect.Left > 0 then {$IFDEF HAS_NATIVEINT} C2 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX xor $FF) {$ELSE} C2 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX xor $FF) {$ENDIF} else C2 := SrcP[0]; BlendMemEx(CombineReg(C1, C2, FracY), DstP^, LW * MA shr 8); Inc(DstP); C1 := C2; // Vertical translation CombineLine(@Buf2[0], @Buf1[0], SrcRectW, FracY xor $FF); // Blend horizontal line to Dst BlendLineEx(@Buf1[0], DstP, SrcRectW - 1, MA); Inc(DstP, SrcRectW - 1); if SrcRect.Right < SrcW then C4 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX) else C4 := SrcP[SrcRectW - 1]; BlendMemEx(CombineReg(C3, C4, FracY), DstP^, RW * MA shr 8); Inc(DstP, DstW - SrcRectW); C3 := C4; Index := Index xor 1; end; Buf1 := @Buffer[Index][0]; Buf2 := @Buffer[Index xor 1][0]; Inc(PColor32(SrcP), SrcW); if SrcRect.Bottom < Src.Height then begin MoveLongWord(SrcP[0], Buf2^, SrcRectW); CombineLine(@Buf2[1], @Buf2[0], SrcRectW, FracY xor $FF); CombineLine(@Buf2[0], @Buf1[0], SrcRectW, FracY xor $FF); if SrcRect.Left > 0 then {$IFDEF HAS_NATIVEINT} C2 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX xor $FF) {$ELSE} C2 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX xor $FF) {$ENDIF} else C2 := SrcP[0]; BlendMemEx(CombineReg(C1, C2, FracY), DstP^, LW * BW * MA shr 16) end else BlendMemEx(C1, DstP^, LW * BW * MA shr 16); Inc(DstP); BlendLineEx(@Buf1[0], DstP, SrcRectW - 1, BW * MA shr 8); Inc(DstP, SrcRectW - 1); if SrcRect.Bottom < Src.Height then begin if SrcRect.Right < SrcW then C4 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX) else C4 := SrcP[SrcRectW - 1]; BlendMemEx(CombineReg(C3, C4, FracY), DstP^, RW * BW * MA shr 16); end else BlendMemEx(C3, DstP^, RW * BW * MA shr 16); finally EMMS; Buffer[0] := nil; Buffer[1] := nil; end; end; Dst.Changed(MakeRect(DstX, DstY, DstX + SrcRectW + 1, DstY + SrcRectH + 1)); end; {$WARNINGS ON} procedure BlendTransfer( Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect; SrcF: TCustomBitmap32; SrcRectF: TRect; SrcB: TCustomBitmap32; SrcRectB: TRect; BlendCallback: TBlendReg); var I, J, SrcFX, SrcFY, SrcBX, SrcBY: Integer; PSrcF, PSrcB, PDst: PColor32Array; begin if not Assigned(Dst) then raise EBitmapException.Create(SDstNil); if not Assigned(SrcF) then raise EBitmapException.Create(SSrcNil); if not Assigned(SrcB) then raise EBitmapException.Create(SSrcNil); if Dst.Empty or SrcF.Empty or SrcB.Empty or not Assigned(BlendCallback) then Exit; if not Dst.MeasuringMode then begin SrcFX := SrcRectF.Left - DstX; SrcFY := SrcRectF.Top - DstY; SrcBX := SrcRectB.Left - DstX; SrcBY := SrcRectB.Top - DstY; GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect); GR32.IntersectRect(SrcRectF, SrcRectF, SrcF.BoundsRect); GR32.IntersectRect(SrcRectB, SrcRectB, SrcB.BoundsRect); GR32.OffsetRect(SrcRectF, -SrcFX, -SrcFY); GR32.OffsetRect(SrcRectB, -SrcBX, -SrcFY); GR32.IntersectRect(DstClip, DstClip, SrcRectF); GR32.IntersectRect(DstClip, DstClip, SrcRectB); if not GR32.IsRectEmpty(DstClip) then try for I := DstClip.Top to DstClip.Bottom - 1 do begin PSrcF := PColor32Array(SrcF.PixelPtr[SrcFX, SrcFY + I]); PSrcB := PColor32Array(SrcB.PixelPtr[SrcBX, SrcBY + I]); PDst := Dst.ScanLine[I]; for J := DstClip.Left to DstClip.Right - 1 do PDst[J] := BlendCallback(PSrcF[J], PSrcB[J]); end; finally EMMS; end; end; Dst.Changed(DstClip); end; procedure BlendTransfer( Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect; SrcF: TCustomBitmap32; SrcRectF: TRect; SrcB: TCustomBitmap32; SrcRectB: TRect; BlendCallback: TBlendRegEx; MasterAlpha: Integer); var I, J, SrcFX, SrcFY, SrcBX, SrcBY: Integer; PSrcF, PSrcB, PDst: PColor32Array; begin if not Assigned(Dst) then raise EBitmapException.Create(SDstNil); if not Assigned(SrcF) then raise EBitmapException.Create(SSrcNil); if not Assigned(SrcB) then raise EBitmapException.Create(SSrcNil); if Dst.Empty or SrcF.Empty or SrcB.Empty or not Assigned(BlendCallback) then Exit; if not Dst.MeasuringMode then begin SrcFX := SrcRectF.Left - DstX; SrcFY := SrcRectF.Top - DstY; SrcBX := SrcRectB.Left - DstX; SrcBY := SrcRectB.Top - DstY; GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect); GR32.IntersectRect(SrcRectF, SrcRectF, SrcF.BoundsRect); GR32.IntersectRect(SrcRectB, SrcRectB, SrcB.BoundsRect); GR32.OffsetRect(SrcRectF, -SrcFX, -SrcFY); GR32.OffsetRect(SrcRectB, -SrcBX, -SrcFY); GR32.IntersectRect(DstClip, DstClip, SrcRectF); GR32.IntersectRect(DstClip, DstClip, SrcRectB); if not GR32.IsRectEmpty(DstClip) then try for I := DstClip.Top to DstClip.Bottom - 1 do begin PSrcF := PColor32Array(SrcF.PixelPtr[SrcFX, SrcFY + I]); PSrcB := PColor32Array(SrcB.PixelPtr[SrcBX, SrcBY + I]); PDst := Dst.ScanLine[I]; for J := DstClip.Left to DstClip.Right - 1 do PDst[J] := BlendCallback(PSrcF[J], PSrcB[J], MasterAlpha); end; finally EMMS; end; end; Dst.Changed(DstClip); end; procedure StretchNearest( Dst: TCustomBitmap32; DstRect, DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); var R: TRect; SrcW, SrcH, DstW, DstH, DstClipW, DstClipH: Integer; SrcY, OldSrcY: Integer; I, J: Integer; MapHorz: PIntegerArray; SrcLine, DstLine: PColor32Array; Buffer: TArrayOfColor32; Scale: TFloat; BlendLine: TBlendLine; BlendLineEx: TBlendLineEx; DstLinePtr, MapPtr: PColor32; begin GR32.IntersectRect(DstClip, DstClip, MakeRect(0, 0, Dst.Width, Dst.Height)); GR32.IntersectRect(DstClip, DstClip, DstRect); if GR32.IsRectEmpty(DstClip) then Exit; GR32.IntersectRect(R, DstClip, DstRect); if GR32.IsRectEmpty(R) then Exit; if (SrcRect.Left < 0) or (SrcRect.Top < 0) or (SrcRect.Right > Src.Width) or (SrcRect.Bottom > Src.Height) then raise Exception.Create(RCStrInvalidSrcRect); SrcW := SrcRect.Right - SrcRect.Left; SrcH := SrcRect.Bottom - SrcRect.Top; DstW := DstRect.Right - DstRect.Left; DstH := DstRect.Bottom - DstRect.Top; DstClipW := DstClip.Right - DstClip.Left; DstClipH := DstClip.Bottom - DstClip.Top; try if (SrcW = DstW) and (SrcH = DstH) then begin { Copy without resampling } BlendBlock(Dst, DstClip, Src, SrcRect.Left + DstClip.Left - DstRect.Left, SrcRect.Top + DstClip.Top - DstRect.Top, CombineOp, CombineCallBack); end else begin GetMem(MapHorz, DstClipW * SizeOf(Integer)); try if DstW > 1 then begin if FullEdge then begin Scale := SrcW / DstW; for I := 0 to DstClipW - 1 do MapHorz^[I] := Trunc(SrcRect.Left + (I + DstClip.Left - DstRect.Left) * Scale); end else begin Scale := (SrcW - 1) / (DstW - 1); for I := 0 to DstClipW - 1 do MapHorz^[I] := Round(SrcRect.Left + (I + DstClip.Left - DstRect.Left) * Scale); end; Assert(MapHorz^[0] >= SrcRect.Left); Assert(MapHorz^[DstClipW - 1] < SrcRect.Right); end else MapHorz^[0] := (SrcRect.Left + SrcRect.Right - 1) div 2; if DstH <= 1 then Scale := 0 else if FullEdge then Scale := SrcH / DstH else Scale := (SrcH - 1) / (DstH - 1); if CombineOp = dmOpaque then begin DstLine := PColor32Array(Dst.PixelPtr[DstClip.Left, DstClip.Top]); OldSrcY := -1; for J := 0 to DstClipH - 1 do begin if DstH <= 1 then SrcY := (SrcRect.Top + SrcRect.Bottom - 1) div 2 else if FullEdge then SrcY := Trunc(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale) else SrcY := Round(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale); if SrcY <> OldSrcY then begin SrcLine := Src.ScanLine[SrcY]; DstLinePtr := @DstLine[0]; MapPtr := @MapHorz^[0]; for I := 0 to DstClipW - 1 do begin DstLinePtr^ := SrcLine[MapPtr^]; Inc(DstLinePtr); Inc(MapPtr); end; OldSrcY := SrcY; end else MoveLongWord(DstLine[-Dst.Width], DstLine[0], DstClipW); Inc(DstLine, Dst.Width); end; end else begin SetLength(Buffer, DstClipW); DstLine := PColor32Array(Dst.PixelPtr[DstClip.Left, DstClip.Top]); OldSrcY := -1; if Src.MasterAlpha >= 255 then begin BlendLine := BLEND_LINE[Src.CombineMode]^; BlendLineEx := nil; // stop compiler warnings... end else begin BlendLineEx := BLEND_LINE_EX[Src.CombineMode]^; BlendLine := nil; // stop compiler warnings... end; for J := 0 to DstClipH - 1 do begin if DstH > 1 then begin EMMS; if FullEdge then SrcY := Trunc(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale) else SrcY := Round(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale); end else SrcY := (SrcRect.Top + SrcRect.Bottom - 1) div 2; if SrcY <> OldSrcY then begin SrcLine := Src.ScanLine[SrcY]; DstLinePtr := @Buffer[0]; MapPtr := @MapHorz^[0]; for I := 0 to DstClipW - 1 do begin DstLinePtr^ := SrcLine[MapPtr^]; Inc(DstLinePtr); Inc(MapPtr); end; OldSrcY := SrcY; end; case CombineOp of dmBlend: if Src.MasterAlpha >= 255 then BlendLine(@Buffer[0], @DstLine[0], DstClipW) else BlendLineEx(@Buffer[0], @DstLine[0], DstClipW, Src.MasterAlpha); dmTransparent: for I := 0 to DstClipW - 1 do if Buffer[I] <> Src.OuterColor then DstLine[I] := Buffer[I]; dmCustom: for I := 0 to DstClipW - 1 do CombineCallBack(Buffer[I], DstLine[I], Src.MasterAlpha); end; Inc(DstLine, Dst.Width); end; end; finally FreeMem(MapHorz); end; end; finally EMMS; end; end; procedure StretchHorzStretchVertLinear( Dst: TCustomBitmap32; DstRect, DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); //Assure DstRect is >= SrcRect, otherwise quality loss will occur var SrcW, SrcH, DstW, DstH, DstClipW, DstClipH: Integer; MapHorz, MapVert: array of TPointRec; t2, Scale: TFloat; SrcLine, DstLine: PColor32Array; SrcIndex: Integer; SrcPtr1, SrcPtr2: PColor32; I, J: Integer; WY: Cardinal; C: TColor32; BlendMemEx: TBlendMemEx; begin SrcW := SrcRect.Right - SrcRect.Left; SrcH := SrcRect.Bottom - SrcRect.Top; DstW := DstRect.Right - DstRect.Left; DstH := DstRect.Bottom - DstRect.Top; DstClipW := DstClip.Right - DstClip.Left; DstClipH := DstClip.Bottom - DstClip.Top; SetLength(MapHorz, DstClipW); if FullEdge then Scale := SrcW / DstW else Scale := (SrcW - 1) / (DstW - 1); for I := 0 to DstClipW - 1 do begin if FullEdge then t2 := SrcRect.Left - 0.5 + (I + DstClip.Left - DstRect.Left + 0.5) * Scale else t2 := SrcRect.Left + (I + DstClip.Left - DstRect.Left) * Scale; if t2 < 0 then t2 := 0 else if t2 > Src.Width - 1 then t2 := Src.Width - 1; MapHorz[I].Pos := Floor(t2); MapHorz[I].Weight := 256 - Round(Frac(t2) * 256); //Pre-pack weights to reduce MMX Reg. setups per pixel: //MapHorz[I].Weight:= MapHorz[I].Weight shl 16 + MapHorz[I].Weight; end; I := DstClipW - 1; while MapHorz[I].Pos = SrcRect.Right - 1 do begin Dec(MapHorz[I].Pos); MapHorz[I].Weight := 0; Dec(I); end; SetLength(MapVert, DstClipH); if FullEdge then Scale := SrcH / DstH else Scale := (SrcH - 1) / (DstH - 1); for I := 0 to DstClipH - 1 do begin if FullEdge then t2 := SrcRect.Top - 0.5 + (I + DstClip.Top - DstRect.Top + 0.5) * Scale else t2 := SrcRect.Top + (I + DstClip.Top - DstRect.Top) * Scale; if t2 < 0 then t2 := 0 else if t2 > Src.Height - 1 then t2 := Src.Height - 1; MapVert[I].Pos := Floor(t2); MapVert[I].Weight := 256 - Round(Frac(t2) * 256); //Pre-pack weights to reduce MMX Reg. setups per pixel: //MapVert[I].Weight := MapVert[I].Weight shl 16 + MapVert[I].Weight; end; I := DstClipH - 1; while MapVert[I].Pos = SrcRect.Bottom - 1 do begin Dec(MapVert[I].Pos); MapVert[I].Weight := 0; Dec(I); end; DstLine := PColor32Array(Dst.PixelPtr[DstClip.Left, DstClip.Top]); SrcW := Src.Width; DstW := Dst.Width; case CombineOp of dmOpaque: for J := 0 to DstClipH - 1 do begin SrcLine := Src.ScanLine[MapVert[J].Pos]; WY := MapVert[J].Weight; SrcIndex := MapHorz[0].Pos; SrcPtr1 := @SrcLine[SrcIndex]; SrcPtr2 := @SrcLine[SrcIndex + SrcW]; for I := 0 to DstClipW - 1 do begin if SrcIndex <> MapHorz[I].Pos then begin SrcIndex := MapHorz[I].Pos; SrcPtr1 := @SrcLine[SrcIndex]; SrcPtr2 := @SrcLine[SrcIndex + SrcW]; end; DstLine[I] := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2); end; Inc(DstLine, DstW); end; dmBlend: begin BlendMemEx := BLEND_MEM_EX[Src.CombineMode]^; for J := 0 to DstClipH - 1 do begin SrcLine := Src.ScanLine[MapVert[J].Pos]; WY := MapVert[J].Weight; SrcIndex := MapHorz[0].Pos; SrcPtr1 := @SrcLine[SrcIndex]; SrcPtr2 := @SrcLine[SrcIndex + SrcW]; for I := 0 to DstClipW - 1 do begin if SrcIndex <> MapHorz[I].Pos then begin SrcIndex := MapHorz[I].Pos; SrcPtr1 := @SrcLine[SrcIndex]; SrcPtr2 := @SrcLine[SrcIndex + SrcW]; end; C := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2); BlendMemEx(C, DstLine[I], Src.MasterAlpha) end; Inc(DstLine, Dst.Width); end end; dmTransparent: begin for J := 0 to DstClipH - 1 do begin SrcLine := Src.ScanLine[MapVert[J].Pos]; WY := MapVert[J].Weight; SrcIndex := MapHorz[0].Pos; SrcPtr1 := @SrcLine[SrcIndex]; SrcPtr2 := @SrcLine[SrcIndex + SrcW]; for I := 0 to DstClipW - 1 do begin if SrcIndex <> MapHorz[I].Pos then begin SrcIndex := MapHorz[I].Pos; SrcPtr1 := @SrcLine[SrcIndex]; SrcPtr2 := @SrcLine[SrcIndex + SrcW]; end; C := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2); if C <> Src.OuterColor then DstLine[I] := C; end; Inc(DstLine, Dst.Width); end end; else // cmCustom for J := 0 to DstClipH - 1 do begin SrcLine := Src.ScanLine[MapVert[J].Pos]; WY := MapVert[J].Weight; SrcIndex := MapHorz[0].Pos; SrcPtr1 := @SrcLine[SrcIndex]; SrcPtr2 := @SrcLine[SrcIndex + SrcW]; for I := 0 to DstClipW - 1 do begin if SrcIndex <> MapHorz[I].Pos then begin SrcIndex := MapHorz[I].Pos; SrcPtr1 := @SrcLine[SrcIndex]; SrcPtr2 := @SrcLine[SrcIndex + SrcW]; end; C := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2); CombineCallBack(C, DstLine[I], Src.MasterAlpha); end; Inc(DstLine, Dst.Width); end; end; EMMS; end; function BuildMappingTable( DstLo, DstHi: Integer; ClipLo, ClipHi: Integer; SrcLo, SrcHi: Integer; Kernel: TCustomKernel): TMappingTable; var SrcW, DstW, ClipW: Integer; Filter: TFilterMethod; FilterWidth: TFloat; Scale, OldScale: TFloat; Center: TFloat; Count: Integer; Left, Right: Integer; I, J, K: Integer; Weight: Integer; begin SrcW := SrcHi - SrcLo; DstW := DstHi - DstLo; ClipW := ClipHi - ClipLo; if SrcW = 0 then begin Result := nil; Exit; end else if SrcW = 1 then begin SetLength(Result, ClipW); for I := 0 to ClipW - 1 do begin SetLength(Result[I], 1); Result[I][0].Pos := SrcLo; Result[I][0].Weight := 256; end; Exit; end; SetLength(Result, ClipW); if ClipW = 0 then Exit; if FullEdge then Scale := DstW / SrcW else Scale := (DstW - 1) / (SrcW - 1); Filter := Kernel.Filter; FilterWidth := Kernel.GetWidth; K := 0; if Scale = 0 then begin Assert(Length(Result) = 1); SetLength(Result[0], 1); Result[0][0].Pos := (SrcLo + SrcHi) div 2; Result[0][0].Weight := 256; end else if Scale < 1 then begin OldScale := Scale; Scale := 1 / Scale; FilterWidth := FilterWidth * Scale; for I := 0 to ClipW - 1 do begin if FullEdge then Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale else Center := SrcLo + (I - DstLo + ClipLo) * Scale; Left := Floor(Center - FilterWidth); Right := Ceil(Center + FilterWidth); Count := -256; for J := Left to Right do begin Weight := Round(256 * Filter((Center - J) * OldScale) * OldScale); if Weight <> 0 then begin Inc(Count, Weight); K := Length(Result[I]); SetLength(Result[I], K + 1); Result[I][K].Pos := Constrain(J, SrcLo, SrcHi - 1); Result[I][K].Weight := Weight; end; end; if Length(Result[I]) = 0 then begin SetLength(Result[I], 1); Result[I][0].Pos := Floor(Center); Result[I][0].Weight := 256; end else if Count <> 0 then Dec(Result[I][K div 2].Weight, Count); end; end else // scale > 1 begin Scale := 1 / Scale; for I := 0 to ClipW - 1 do begin if FullEdge then Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale else Center := SrcLo + (I - DstLo + ClipLo) * Scale; Left := Floor(Center - FilterWidth); Right := Ceil(Center + FilterWidth); Count := -256; for J := Left to Right do begin Weight := Round(256 * Filter(Center - j)); if Weight <> 0 then begin Inc(Count, Weight); K := Length(Result[I]); SetLength(Result[I], k + 1); Result[I][K].Pos := Constrain(j, SrcLo, SrcHi - 1); Result[I][K].Weight := Weight; end; end; if Count <> 0 then Dec(Result[I][K div 2].Weight, Count); end; end; end; {$WARNINGS OFF} procedure Resample( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; Kernel: TCustomKernel; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); var DstClipW: Integer; MapX, MapY: TMappingTable; I, J, X, Y: Integer; MapXLoPos, MapXHiPos: Integer; HorzBuffer: array of TBufferEntry; ClusterX, ClusterY: TCluster; Wt, Cr, Cg, Cb, Ca: Integer; C: Cardinal; ClustYW: Integer; DstLine: PColor32Array; RangeCheck: Boolean; BlendMemEx: TBlendMemEx; begin if (CombineOp = dmCustom) and not Assigned(CombineCallBack) then CombineOp := dmOpaque; { check source and destination } if (CombineOp = dmBlend) and (Src.MasterAlpha = 0) then Exit; BlendMemEx := BLEND_MEM_EX[Src.CombineMode]^; // store in local variable DstClipW := DstClip.Right - DstClip.Left; // mapping tables MapX := BuildMappingTable(DstRect.Left, DstRect.Right, DstClip.Left, DstClip.Right, SrcRect.Left, SrcRect.Right, Kernel); MapY := BuildMappingTable(DstRect.Top, DstRect.Bottom, DstClip.Top, DstClip.Bottom, SrcRect.Top, SrcRect.Bottom, Kernel); ClusterX := nil; ClusterY := nil; try RangeCheck := Kernel.RangeCheck; //StretchFilter in [sfLanczos, sfMitchell]; if (MapX = nil) or (MapY = nil) then Exit; MapXLoPos := MapX[0][0].Pos; MapXHiPos := MapX[DstClipW - 1][High(MapX[DstClipW - 1])].Pos; SetLength(HorzBuffer, MapXHiPos - MapXLoPos + 1); { transfer pixels } for J := DstClip.Top to DstClip.Bottom - 1 do begin ClusterY := MapY[J - DstClip.Top]; for X := MapXLoPos to MapXHiPos do begin Ca := 0; Cr := 0; Cg := 0; Cb := 0; for Y := 0 to Length(ClusterY) - 1 do begin C := Src.Bits[X + ClusterY[Y].Pos * Src.Width]; ClustYW := ClusterY[Y].Weight; Inc(Ca, Integer(C shr 24) * ClustYW); Inc(Cr, Integer(C and $00FF0000) shr 16 * ClustYW); Inc(Cg, Integer(C and $0000FF00) shr 8 * ClustYW); Inc(Cb, Integer(C and $000000FF) * ClustYW); end; with HorzBuffer[X - MapXLoPos] do begin R := Cr; G := Cg; B := Cb; A := Ca; end; end; DstLine := Dst.ScanLine[J]; for I := DstClip.Left to DstClip.Right - 1 do begin ClusterX := MapX[I - DstClip.Left]; Ca := 0; Cr := 0; Cg := 0; Cb := 0; for X := 0 to Length(ClusterX) - 1 do begin Wt := ClusterX[X].Weight; with HorzBuffer[ClusterX[X].Pos - MapXLoPos] do begin Inc(Ca, A * Wt); Inc(Cr, R * Wt); Inc(Cg, G * Wt); Inc(Cb, B * Wt); end; end; if RangeCheck then begin if Ca > $FF0000 then Ca := $FF0000 else if Ca < 0 then Ca := 0 else Ca := Ca and $00FF0000; if Cr > $FF0000 then Cr := $FF0000 else if Cr < 0 then Cr := 0 else Cr := Cr and $00FF0000; if Cg > $FF0000 then Cg := $FF0000 else if Cg < 0 then Cg := 0 else Cg := Cg and $00FF0000; if Cb > $FF0000 then Cb := $FF0000 else if Cb < 0 then Cb := 0 else Cb := Cb and $00FF0000; C := (Ca shl 8) or Cr or (Cg shr 8) or (Cb shr 16); end else C := ((Ca and $00FF0000) shl 8) or (Cr and $00FF0000) or ((Cg and $00FF0000) shr 8) or ((Cb and $00FF0000) shr 16); // combine it with the background case CombineOp of dmOpaque: DstLine[I] := C; dmBlend: BlendMemEx(C, DstLine[I], Src.MasterAlpha); dmTransparent: if C <> Src.OuterColor then DstLine[I] := C; dmCustom: CombineCallBack(C, DstLine[I], Src.MasterAlpha); end; end; end; finally EMMS; MapX := nil; MapY := nil; end; end; {$WARNINGS ON} { Draft Resample Routines } function BlockAverage_Pas(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32; var C: PColor32Entry; ix, iy, iA, iR, iG, iB, Area: Cardinal; begin iR := 0; iB := iR; iG := iR; iA := iR; for iy := 1 to Dly do begin C := PColor32Entry(RowSrc); for ix := 1 to Dlx do begin Inc(iB, C.B); Inc(iG, C.G); Inc(iR, C.R); Inc(iA, C.A); Inc(C); end; {$IFDEF HAS_NATIVEINT} Inc(NativeUInt(RowSrc), OffSrc); {$ELSE} Inc(PByte(RowSrc), OffSrc); {$ENDIF} end; Area := Dlx * Dly; Area := $1000000 div Area; Result := iA * Area and $FF000000 or iR * Area shr 8 and $FF0000 or iG * Area shr 16 and $FF00 or iB * Area shr 24 and $FF; end; {$IFNDEF PUREPASCAL} function BlockAverage_MMX(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32; asm {$IFDEF TARGET_X64} MOV R10D,ECX MOV R11D,EDX SHL R10,$02 SUB R9,R10 PXOR MM1,MM1 PXOR MM2,MM2 PXOR MM7,MM7 @@LoopY: MOV R10,RCX PXOR MM0,MM0 LEA R8,[R8+R10*4] NEG R10 @@LoopX: MOVD MM6,[R8+R10*4] PUNPCKLBW MM6,MM7 PADDW MM0,MM6 INC R10 JNZ @@LoopX MOVQ MM6,MM0 PUNPCKLWD MM6,MM7 PADDD MM1,MM6 MOVQ MM6,MM0 PUNPCKHWD MM6,MM7 PADDD MM2,MM6 ADD R8,R9 DEC EDX JNZ @@LoopY MOV EAX, ECX MUL R11D MOV ECX,EAX MOV EAX,$01000000 DIV ECX MOV ECX,EAX MOVD EAX,MM1 MUL ECX SHR EAX,$18 MOV R11D,EAX PSRLQ MM1,$20 MOVD EAX,MM1 MUL ECX SHR EAX,$10 AND EAX,$0000FF00 ADD R11D,EAX MOVD EAX,MM2 MUL ECX SHR EAX,$08 AND EAX,$00FF0000 ADD R11D,EAX PSRLQ MM2,$20 MOVD EAX,MM2 MUL ECX AND EAX,$FF000000 ADD EAX,R11D {$ELSE} PUSH EBX PUSH ESI PUSH EDI MOV EBX,OffSrc MOV ESI,EAX MOV EDI,EDX SHL ESI,$02 SUB EBX,ESI PXOR MM1,MM1 PXOR MM2,MM2 PXOR MM7,MM7 @@LoopY: MOV ESI,EAX PXOR MM0,MM0 LEA ECX,[ECX+ESI*4] NEG ESI @@LoopX: MOVD MM6,[ECX+ESI*4] PUNPCKLBW MM6,MM7 PADDW MM0,MM6 INC ESI JNZ @@LoopX MOVQ MM6,MM0 PUNPCKLWD MM6,MM7 PADDD MM1,MM6 MOVQ MM6,MM0 PUNPCKHWD MM6,MM7 PADDD MM2,MM6 ADD ECX,EBX DEC EDX JNZ @@LoopY MUL EDI MOV ECX,EAX MOV EAX,$01000000 DIV ECX MOV ECX,EAX MOVD EAX,MM1 MUL ECX SHR EAX,$18 MOV EDI,EAX PSRLQ MM1,$20 MOVD EAX,MM1 MUL ECX SHR EAX,$10 AND EAX,$0000FF00 ADD EDI,EAX MOVD EAX,MM2 MUL ECX SHR EAX,$08 AND EAX,$00FF0000 ADD EDI,EAX PSRLQ MM2,$20 MOVD EAX,MM2 MUL ECX AND EAX,$FF000000 ADD EAX,EDI POP EDI POP ESI POP EBX {$ENDIF} end; {$IFDEF USE_3DNOW} function BlockAverage_3DNow(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32; asm PUSH EBX PUSH ESI PUSH EDI MOV EBX,OffSrc MOV ESI,EAX MOV EDI,EDX SHL ESI,$02 SUB EBX,ESI PXOR MM1,MM1 PXOR MM2,MM2 PXOR MM7,MM7 @@LoopY: MOV ESI,EAX PXOR MM0,MM0 LEA ECX,[ECX+ESI*4] NEG ESI db $0F,$0D,$84,$B1,$00,$02,$00,$00 // PREFETCH [ECX + ESI * 4 + 512] @@LoopX: MOVD MM6,[ECX + ESI * 4] PUNPCKLBW MM6,MM7 PADDW MM0,MM6 INC ESI JNZ @@LoopX MOVQ MM6,MM0 PUNPCKLWD MM6,MM7 PADDD MM1,MM6 MOVQ MM6,MM0 PUNPCKHWD MM6,MM7 PADDD MM2,MM6 ADD ECX,EBX DEC EDX JNZ @@LoopY MUL EDI MOV ECX,EAX MOV EAX,$01000000 div ECX MOV ECX,EAX MOVD EAX,MM1 MUL ECX SHR EAX,$18 MOV EDI,EAX PSRLQ MM1,$20 MOVD EAX,MM1 MUL ECX SHR EAX,$10 AND EAX,$0000FF00 ADD EDI,EAX MOVD EAX,MM2 MUL ECX SHR EAX,$08 AND EAX,$00FF0000 ADD EDI,EAX PSRLQ MM2,$20 MOVD EAX,MM2 MUL ECX AND EAX,$FF000000 ADD EAX,EDI POP EDI POP ESI POP EBX end; {$ENDIF} function BlockAverage_SSE2(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32; asm {$IFDEF TARGET_X64} MOV EAX,ECX MOV R10D,EDX SHL EAX,$02 SUB R9D,EAX PXOR XMM1,XMM1 PXOR XMM2,XMM2 PXOR XMM7,XMM7 @@LoopY: MOV EAX,ECX PXOR XMM0,XMM0 LEA R8,[R8+RAX*4] NEG RAX @@LoopX: MOVD XMM6,[R8+RAX*4] PUNPCKLBW XMM6,XMM7 PADDW XMM0,XMM6 INC RAX JNZ @@LoopX MOVQ XMM6,XMM0 PUNPCKLWD XMM6,XMM7 PADDD XMM1,XMM6 ADD R8,R9 DEC EDX JNZ @@LoopY MOV EAX, ECX MUL R10D MOV ECX,EAX MOV EAX,$01000000 DIV ECX MOV ECX,EAX MOVD EAX,XMM1 MUL ECX SHR EAX,$18 MOV R10D,EAX SHUFPS XMM1,XMM1,$39 MOVD EAX,XMM1 MUL ECX SHR EAX,$10 AND EAX,$0000FF00 ADD R10D,EAX PSHUFD XMM1,XMM1,$39 MOVD EAX,XMM1 MUL ECX SHR EAX,$08 AND EAX,$00FF0000 ADD R10D,EAX PSHUFD XMM1,XMM1,$39 MOVD EAX,XMM1 MUL ECX AND EAX,$FF000000 ADD EAX,R10D {$ELSE} PUSH EBX PUSH ESI PUSH EDI MOV EBX,OffSrc MOV ESI,EAX MOV EDI,EDX SHL ESI,$02 SUB EBX,ESI PXOR XMM1,XMM1 PXOR XMM2,XMM2 PXOR XMM7,XMM7 @@LoopY: MOV ESI,EAX PXOR XMM0,XMM0 LEA ECX,[ECX+ESI*4] NEG ESI @@LoopX: MOVD XMM6,[ECX+ESI*4] PUNPCKLBW XMM6,XMM7 PADDW XMM0,XMM6 INC ESI JNZ @@LoopX MOVQ XMM6,XMM0 PUNPCKLWD XMM6,XMM7 PADDD XMM1,XMM6 ADD ECX,EBX DEC EDX JNZ @@LoopY MUL EDI MOV ECX,EAX MOV EAX,$01000000 DIV ECX MOV ECX,EAX MOVD EAX,XMM1 MUL ECX SHR EAX,$18 MOV EDI,EAX SHUFPS XMM1,XMM1,$39 MOVD EAX,XMM1 MUL ECX SHR EAX,$10 AND EAX,$0000FF00 ADD EDI,EAX PSHUFD XMM1,XMM1,$39 MOVD EAX,XMM1 MUL ECX SHR EAX,$08 AND EAX,$00FF0000 ADD EDI,EAX PSHUFD XMM1,XMM1,$39 MOVD EAX,XMM1 MUL ECX AND EAX,$FF000000 ADD EAX,EDI POP EDI POP ESI POP EBX {$ENDIF} end; {$ENDIF} procedure DraftResample(Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; Kernel: TCustomKernel; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); var SrcW, SrcH, DstW, DstH, DstClipW, DstClipH: Cardinal; RowSrc: PColor32; xsrc: PColor32; OffSrc, dy, dx, c1, c2, r1, r2, xs: Cardinal; C: TColor32; DstLine: PColor32Array; ScaleFactor: TFloat; I,J, sc, sr, cx, cy: Integer; BlendMemEx: TBlendMemEx; begin { rangechecking and rect intersection done by caller } SrcW := SrcRect.Right - SrcRect.Left; SrcH := SrcRect.Bottom - SrcRect.Top; DstW := DstRect.Right - DstRect.Left; DstH := DstRect.Bottom - DstRect.Top; DstClipW := DstClip.Right - DstClip.Left; DstClipH := DstClip.Bottom - DstClip.Top; BlendMemEx := BLEND_MEM_EX[Src.CombineMode]^; if (DstW > SrcW)or(DstH > SrcH) then begin if (SrcW < 2) or (SrcH < 2) then Resample(Dst, DstRect, DstClip, Src, SrcRect, Kernel, CombineOp, CombineCallBack) else StretchHorzStretchVertLinear(Dst, DstRect, DstClip, Src, SrcRect, CombineOp, CombineCallBack); end else begin //Full Scaledown, ignores Fulledge - cannot be integrated into this resampling method OffSrc := Src.Width * 4; ScaleFactor:= SrcW / DstW; cx := Trunc( (DstClip.Left - DstRect.Left) * ScaleFactor); r2 := Trunc(ScaleFactor); sr := Trunc( $10000 * ScaleFactor ); ScaleFactor:= SrcH / DstH; cy := Trunc( (DstClip.Top - DstRect.Top) * ScaleFactor); c2 := Trunc(ScaleFactor); sc := Trunc( $10000 * ScaleFactor ); DstLine := PColor32Array(Dst.PixelPtr[0, DstClip.Top]); RowSrc := Src.PixelPtr[SrcRect.Left + cx, SrcRect.Top + cy ]; xs := r2; c1 := 0; Dec(DstClip.Left, 2); Inc(DstClipW); Inc(DstClipH); for J := 2 to DstClipH do begin dy := c2 - c1; c1 := c2; c2 := FixedMul(J, sc); r1 := 0; r2 := xs; xsrc := RowSrc; case CombineOp of dmOpaque: for I := 2 to DstClipW do begin dx := r2 - r1; r1 := r2; r2 := FixedMul(I, sr); DstLine[DstClip.Left + I] := BlockAverage(dx, dy, xsrc, OffSrc); Inc(xsrc, dx); end; dmBlend: for I := 2 to DstClipW do begin dx := r2 - r1; r1 := r2; r2 := FixedMul(I, sr); BlendMemEx(BlockAverage(dx, dy, xsrc, OffSrc), DstLine[DstClip.Left + I], Src.MasterAlpha); Inc(xsrc, dx); end; dmTransparent: for I := 2 to DstClipW do begin dx := r2 - r1; r1 := r2; r2 := FixedMul(I, sr); C := BlockAverage(dx, dy, xsrc, OffSrc); if C <> Src.OuterColor then DstLine[DstClip.Left + I] := C; Inc(xsrc, dx); end; dmCustom: for I := 2 to DstClipW do begin dx := r2 - r1; r1 := r2; r2 := FixedMul(I, sr); CombineCallBack(BlockAverage(dx, dy, xsrc, OffSrc), DstLine[DstClip.Left + I], Src.MasterAlpha); Inc(xsrc, dx); end; end; Inc(DstLine, Dst.Width); {$IFDEF HAS_NATIVEINT} Inc(NativeUInt(RowSrc), OffSrc * dy); {$ELSE} Inc(PByte(RowSrc), OffSrc * dy); {$ENDIF} end; end; EMMS; end; { Special interpolators (for sfLinear and sfDraft) } function Interpolator_Pas(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32; var C1, C3: TColor32; begin if WX_256 > $FF then WX_256:= $FF; if WY_256 > $FF then WY_256:= $FF; C1 := C11^; Inc(C11); C3 := C21^; Inc(C21); Result := CombineReg(CombineReg(C1, C11^, WX_256), CombineReg(C3, C21^, WX_256), WY_256); end; {$IFNDEF PUREPASCAL} function Interpolator_MMX(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32; asm {$IFDEF TARGET_X64} MOV RAX, RCX MOVQ MM1,QWORD PTR [R8] MOVQ MM2,MM1 MOVQ MM3,QWORD PTR [R9] {$ELSE} MOVQ MM1,[ECX] MOVQ MM2,MM1 MOV ECX,C21 MOVQ MM3,[ECX] {$ENDIF} PSRLQ MM1,32 MOVQ MM4,MM3 PSRLQ MM3,32 MOVD MM5,EAX PSHUFW MM5,MM5,0 PXOR MM0,MM0 PUNPCKLBW MM1,MM0 PUNPCKLBW MM2,MM0 PSUBW MM2,MM1 PMULLW MM2,MM5 PSLLW MM1,8 PADDW MM2,MM1 PSRLW MM2,8 PUNPCKLBW MM3,MM0 PUNPCKLBW MM4,MM0 PSUBW MM4,MM3 PSLLW MM3,8 PMULLW MM4,MM5 PADDW MM4,MM3 PSRLW MM4,8 MOVD MM5,EDX PSHUFW MM5,MM5,0 PSUBW MM2,MM4 PMULLW MM2,MM5 PSLLW MM4,8 PADDW MM2,MM4 PSRLW MM2,8 PACKUSWB MM2,MM0 MOVD EAX,MM2 end; function Interpolator_SSE2(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32; asm {$IFDEF TARGET_X64} MOV RAX, RCX MOVQ XMM1,QWORD PTR [R8] MOVQ XMM2,XMM1 MOVQ XMM3,QWORD PTR [R9] {$ELSE} MOVQ XMM1,[ECX] MOVQ XMM2,XMM1 MOV ECX,C21 MOVQ XMM3,[ECX] {$ENDIF} PSRLQ XMM1,32 MOVQ XMM4,XMM3 PSRLQ XMM3,32 MOVD XMM5,EAX PSHUFLW XMM5,XMM5,0 PXOR XMM0,XMM0 PUNPCKLBW XMM1,XMM0 PUNPCKLBW XMM2,XMM0 PSUBW XMM2,XMM1 PMULLW XMM2,XMM5 PSLLW XMM1,8 PADDW XMM2,XMM1 PSRLW XMM2,8 PUNPCKLBW XMM3,XMM0 PUNPCKLBW XMM4,XMM0 PSUBW XMM4,XMM3 PSLLW XMM3,8 PMULLW XMM4,XMM5 PADDW XMM4,XMM3 PSRLW XMM4,8 MOVD XMM5,EDX PSHUFLW XMM5,XMM5,0 PSUBW XMM2,XMM4 PMULLW XMM2,XMM5 PSLLW XMM4,8 PADDW XMM2,XMM4 PSRLW XMM2,8 PACKUSWB XMM2,XMM0 MOVD EAX,XMM2 end; {$ENDIF} { Stretch Transfer } {$WARNINGS OFF} procedure StretchTransfer( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; Resampler: TCustomResampler; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); var SrcW, SrcH: Integer; DstW, DstH: Integer; R: TRect; RatioX, RatioY: Single; begin CheckBitmaps(Dst, Src); // transform dest rect when the src rect is out of the src bitmap's bounds if (SrcRect.Left < 0) or (SrcRect.Right > Src.Width) or (SrcRect.Top < 0) or (SrcRect.Bottom > Src.Height) then begin RatioX := (DstRect.Right - DstRect.Left) / (SrcRect.Right - SrcRect.Left); RatioY := (DstRect.Bottom - DstRect.Top) / (SrcRect.Bottom - SrcRect.Top); if SrcRect.Left < 0 then begin DstRect.Left := DstRect.Left + Ceil(-SrcRect.Left * RatioX); SrcRect.Left := 0; end; if SrcRect.Top < 0 then begin DstRect.Top := DstRect.Top + Ceil(-SrcRect.Top * RatioY); SrcRect.Top := 0; end; if SrcRect.Right > Src.Width then begin DstRect.Right := DstRect.Right - Floor((SrcRect.Right - Src.Width) * RatioX); SrcRect.Right := Src.Width; end; if SrcRect.Bottom > Src.Height then begin DstRect.Bottom := DstRect.Bottom - Floor((SrcRect.Bottom - Src.Height) * RatioY); SrcRect.Bottom := Src.Height; end; end; if Src.Empty or Dst.Empty or ((CombineOp = dmBlend) and (Src.MasterAlpha = 0)) or GR32.IsRectEmpty(SrcRect) then Exit; if not Dst.MeasuringMode then begin GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect); GR32.IntersectRect(DstClip, DstClip, DstRect); if GR32.IsRectEmpty(DstClip) then Exit; GR32.IntersectRect(R, DstClip, DstRect); if GR32.IsRectEmpty(R) then Exit; if (CombineOp = dmCustom) and not Assigned(CombineCallBack) then CombineOp := dmOpaque; SrcW := SrcRect.Right - SrcRect.Left; SrcH := SrcRect.Bottom - SrcRect.Top; DstW := DstRect.Right - DstRect.Left; DstH := DstRect.Bottom - DstRect.Top; try if (SrcW = DstW) and (SrcH = DstH) then BlendBlock(Dst, DstClip, Src, SrcRect.Left + DstClip.Left - DstRect.Left, SrcRect.Top + DstClip.Top - DstRect.Top, CombineOp, CombineCallBack) else TCustomResamplerAccess(Resampler).Resample( Dst, DstRect, DstClip, Src, SrcRect, CombineOp, CombineCallBack); finally EMMS; end; end; Dst.Changed(DstRect); end; {$WARNINGS ON} { TCustomKernel } procedure TCustomKernel.AssignTo(Dst: TPersistent); begin if Dst is TCustomKernel then SmartAssign(Self, Dst) else inherited; end; procedure TCustomKernel.Changed; begin if Assigned(FObserver) then FObserver.Changed; end; constructor TCustomKernel.Create; begin end; function TCustomKernel.RangeCheck: Boolean; begin Result := False; end; { TBoxKernel } function TBoxKernel.Filter(Value: TFloat): TFloat; begin if (Value >= -0.5) and (Value <= 0.5) then Result := 1.0 else Result := 0; end; function TBoxKernel.GetWidth: TFloat; begin Result := 1; end; { TLinearKernel } function TLinearKernel.Filter(Value: TFloat): TFloat; begin if Value < -1 then Result := 0 else if Value < 0 then Result := 1 + Value else if Value < 1 then Result := 1 - Value else Result := 0; end; function TLinearKernel.GetWidth: TFloat; begin Result := 1; end; { TCosineKernel } function TCosineKernel.Filter(Value: TFloat): TFloat; begin Result := 0; if Abs(Value) < 1 then Result := (Cos(Value * Pi) + 1) * 0.5; end; function TCosineKernel.GetWidth: TFloat; begin Result := 1; end; { TSplineKernel } function TSplineKernel.Filter(Value: TFloat): TFloat; var tt: TFloat; const TwoThirds = 2 / 3; OneSixth = 1 / 6; begin Value := Abs(Value); if Value < 1 then begin tt := Sqr(Value); Result := 0.5 * tt * Value - tt + TwoThirds; end else if Value < 2 then begin Value := 2 - Value; Result := OneSixth * Sqr(Value) * Value; end else Result := 0; end; function TSplineKernel.RangeCheck: Boolean; begin Result := True; end; function TSplineKernel.GetWidth: TFloat; begin Result := 2; end; { TWindowedSincKernel } function SInc(Value: TFloat): TFloat; begin if Value <> 0 then begin Value := Value * Pi; Result := Sin(Value) / Value; end else Result := 1; end; constructor TWindowedSincKernel.Create; begin FWidth := 3; FWidthReciprocal := 1 / FWidth; end; function TWindowedSincKernel.Filter(Value: TFloat): TFloat; begin Value := Abs(Value); if Value < FWidth then Result := SInc(Value) * Window(Value) else Result := 0; end; function TWindowedSincKernel.RangeCheck: Boolean; begin Result := True; end; procedure TWindowedSincKernel.SetWidth(Value: TFloat); begin Value := Min(MAX_KERNEL_WIDTH, Value); if Value <> FWidth then begin FWidth := Value; FWidthReciprocal := 1 / FWidth; Changed; end; end; function TWindowedSincKernel.GetWidth: TFloat; begin Result := FWidth; end; { TAlbrechtKernel } constructor TAlbrechtKernel.Create; begin inherited; Terms := 7; end; procedure TAlbrechtKernel.SetTerms(Value: Integer); begin if (Value < 2) then Value := 2; if (Value > 11) then Value := 11; if FTerms <> Value then begin FTerms := Value; case Value of 2 : Move(CAlbrecht2 [0], FCoefPointer[0], Value * SizeOf(Double)); 3 : Move(CAlbrecht3 [0], FCoefPointer[0], Value * SizeOf(Double)); 4 : Move(CAlbrecht4 [0], FCoefPointer[0], Value * SizeOf(Double)); 5 : Move(CAlbrecht5 [0], FCoefPointer[0], Value * SizeOf(Double)); 6 : Move(CAlbrecht6 [0], FCoefPointer[0], Value * SizeOf(Double)); 7 : Move(CAlbrecht7 [0], FCoefPointer[0], Value * SizeOf(Double)); 8 : Move(CAlbrecht8 [0], FCoefPointer[0], Value * SizeOf(Double)); 9 : Move(CAlbrecht9 [0], FCoefPointer[0], Value * SizeOf(Double)); 10 : Move(CAlbrecht10[0], FCoefPointer[0], Value * SizeOf(Double)); 11 : Move(CAlbrecht11[0], FCoefPointer[0], Value * SizeOf(Double)); end; end; end; function TAlbrechtKernel.Window(Value: TFloat): TFloat; var cs : Double; i : Integer; begin cs := Cos(Pi * Value * FWidthReciprocal); i := FTerms - 1; Result := FCoefPointer[i]; while i > 0 do begin Dec(i); Result := Result * cs + FCoefPointer[i]; end; end; { TLanczosKernel } function TLanczosKernel.Window(Value: TFloat): TFloat; begin Result := SInc(Value * FWidthReciprocal); // Get rid of division end; { TMitchellKernel } function TMitchellKernel.Filter(Value: TFloat): TFloat; var tt, ttt: TFloat; const OneEighteenth = 1 / 18; begin Value := Abs(Value); tt := Sqr(Value); ttt := tt * Value; if Value < 1 then Result := (21 * ttt - 36 * tt + 16 ) * OneEighteenth // get rid of divisions else if Value < 2 then Result := (- 7 * ttt + 36 * tt - 60 * Value + 32) * OneEighteenth // " else Result := 0; end; function TMitchellKernel.RangeCheck: Boolean; begin Result := True; end; function TMitchellKernel.GetWidth: TFloat; begin Result := 2; end; { TCubicKernel } constructor TCubicKernel.Create; begin FCoeff := -0.5; end; function TCubicKernel.Filter(Value: TFloat): TFloat; var tt, ttt: TFloat; begin Value := Abs(Value); tt := Sqr(Value); ttt := tt * Value; if Value < 1 then Result := (FCoeff + 2) * ttt - (FCoeff + 3) * tt + 1 else if Value < 2 then Result := FCoeff * (ttt - 5 * tt + 8 * Value - 4) else Result := 0; end; function TCubicKernel.RangeCheck: Boolean; begin Result := True; end; function TCubicKernel.GetWidth: TFloat; begin Result := 2; end; { TGaussKernel } constructor TGaussianKernel.Create; begin inherited; FSigma := 1.33; FSigmaReciprocalLn2 := -Ln(2) / FSigma; end; procedure TGaussianKernel.SetSigma(const Value: TFloat); begin if (FSigma <> Value) and (FSigma <> 0) then begin FSigma := Value; FSigmaReciprocalLn2 := -Ln(2) / FSigma; Changed; end; end; function TGaussianKernel.Window(Value: TFloat): TFloat; begin Result := Exp(Sqr(Value) * FSigmaReciprocalLn2); // get rid of nasty LN2 and divition end; procedure TCubicKernel.SetCoeff(const Value: TFloat); begin if Value <> FCoeff then begin FCoeff := Value; Changed; end end; { TBlackmanKernel } function TBlackmanKernel.Window(Value: TFloat): TFloat; begin Value := Cos(Pi * Value * FWidthReciprocal); // get rid of division Result := 0.34 + 0.5 * Value + 0.16 * sqr(Value); end; { THannKernel } function THannKernel.Window(Value: TFloat): TFloat; begin Result := 0.5 + 0.5 * Cos(Pi * Value * FWidthReciprocal); // get rid of division end; { THammingKernel } function THammingKernel.Window(Value: TFloat): TFloat; begin Result := 0.54 + 0.46 * Cos(Pi * Value * FWidthReciprocal); // get rid of division end; { TSinshKernel } constructor TSinshKernel.Create; begin FWidth := 3; FCoeff := 0.5; end; function TSinshKernel.Filter(Value: TFloat): TFloat; begin if Value = 0 then Result := 1 else Result := FCoeff * Sin(Pi * Value) / Sinh(Pi * FCoeff * Value); end; function TSinshKernel.RangeCheck: Boolean; begin Result := True; end; procedure TSinshKernel.SetWidth(Value: TFloat); begin if FWidth <> Value then begin FWidth := Value; Changed; end; end; function TSinshKernel.GetWidth: TFloat; begin Result := FWidth; end; procedure TSinshKernel.SetCoeff(const Value: TFloat); begin if (FCoeff <> Value) and (FCoeff <> 0) then begin FCoeff := Value; Changed; end; end; { THermiteKernel } constructor THermiteKernel.Create; begin FBias := 0; FTension := 0; end; function THermiteKernel.Filter(Value: TFloat): TFloat; var Z: Integer; t, t2, t3, m0, m1, a0, a1, a2, a3: TFloat; begin t := (1 - FTension) * 0.5; m0 := (1 + FBias) * t; m1 := (1 - FBias) * t; Z := Floor(Value); t := Abs(Z - Value); t2 := t * t; t3 := t2 * t; a1 := t3 - 2 * t2 + t; a2 := t3 - t2; a3 := -2 * t3 + 3 * t2; a0 := -a3 + 1; case Z of -2: Result := a2 * m1; -1: Result := a3 + a1 * m1 + a2 * (m0 - m1); 0: Result := a0 + a1 * (m0 - m1) - a2 * m0; 1: Result := -a1 * m0; else Result := 0; end; end; function THermiteKernel.GetWidth: TFloat; begin Result := 2; end; function THermiteKernel.RangeCheck: Boolean; begin Result := True; end; procedure THermiteKernel.SetBias(const Value: TFloat); begin if FBias <> Value then begin FBias := Value; Changed; end; end; procedure THermiteKernel.SetTension(const Value: TFloat); begin if FTension <> Value then begin FTension := Value; Changed; end; end; { TKernelResampler } constructor TKernelResampler.Create; begin inherited; Kernel := TBoxKernel.Create; FTableSize := 32; end; destructor TKernelResampler.Destroy; begin FKernel.Free; inherited; end; function TKernelResampler.GetKernelClassName: string; begin Result := FKernel.ClassName; end; procedure TKernelResampler.SetKernelClassName(const Value: string); var KernelClass: TCustomKernelClass; begin if (Value <> '') and (FKernel.ClassName <> Value) and Assigned(KernelList) then begin KernelClass := TCustomKernelClass(KernelList.Find(Value)); if Assigned(KernelClass) then begin FKernel.Free; FKernel := KernelClass.Create; Changed; end; end; end; procedure TKernelResampler.SetKernel(const Value: TCustomKernel); begin if Assigned(Value) and (FKernel <> Value) then begin FKernel.Free; FKernel := Value; Changed; end; end; procedure TKernelResampler.Resample(Dst: TCustomBitmap32; DstRect, DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); begin GR32_Resamplers.Resample(Dst, DstRect, DstClip, Src, SrcRect, FKernel, CombineOp, CombineCallBack); end; {$WARNINGS OFF} function TKernelResampler.GetSampleFloat(X, Y: TFloat): TColor32; var clX, clY: Integer; fracX, fracY: Integer; fracXS: TFloat absolute fracX; fracYS: TFloat absolute fracY; Filter: TFilterMethod; WrapProcVert: TWrapProcEx absolute Filter; WrapProcHorz: TWrapProcEx; Colors: PColor32EntryArray; KWidth, W, Wv, I, J, Incr, Dev: Integer; SrcP: PColor32Entry; C: TColor32Entry absolute SrcP; LoX, HiX, LoY, HiY, MappingY: Integer; HorzKernel, VertKernel: TKernelEntry; PHorzKernel, PVertKernel, FloorKernel, CeilKernel: PKernelEntry; HorzEntry, VertEntry: TBufferEntry; MappingX: TKernelEntry; Edge: Boolean; Alpha: integer; OuterPremultColorR, OuterPremultColorG, OuterPremultColorB: Byte; begin KWidth := Ceil(FKernel.GetWidth); clX := Ceil(X); clY := Ceil(Y); case PixelAccessMode of pamUnsafe, pamWrap: begin LoX := -KWidth; HiX := KWidth; LoY := -KWidth; HiY := KWidth; end; pamSafe, pamTransparentEdge: begin with ClipRect do begin if not ((clX < Left) or (clX > Right) or (clY < Top) or (clY > Bottom)) then begin Edge := False; if clX - KWidth < Left then begin LoX := Left - clX; Edge := True; end else LoX := -KWidth; if clX + KWidth >= Right then begin HiX := Right - clX - 1; Edge := True; end else HiX := KWidth; if clY - KWidth < Top then begin LoY := Top - clY; Edge := True; end else LoY := -KWidth; if clY + KWidth >= Bottom then begin HiY := Bottom - clY - 1; Edge := True; end else HiY := KWidth; end else begin if PixelAccessMode = pamTransparentEdge then Result := 0 else Result := FOuterColor; Exit; end; end; end; end; case FKernelMode of kmDynamic: begin Filter := FKernel.Filter; fracXS := clX - X; fracYS := clY - Y; PHorzKernel := @HorzKernel; PVertKernel := @VertKernel; Dev := -256; for I := -KWidth to KWidth do begin W := Round(Filter(I + fracXS) * 256); HorzKernel[I] := W; Inc(Dev, W); end; Dec(HorzKernel[0], Dev); Dev := -256; for I := -KWidth to KWidth do begin W := Round(Filter(I + fracYS) * 256); VertKernel[I] := W; Inc(Dev, W); end; Dec(VertKernel[0], Dev); end; kmTableNearest: begin W := FWeightTable.Height - 2; PHorzKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Round((clX - X) * W)]^; PVertKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Round((clY - Y) * W)]^; end; kmTableLinear: begin W := (FWeightTable.Height - 2) * $10000; J := FWeightTable.Width * 4; with TFixedRec(FracX) do begin Fixed := Round((clX - X) * W); PHorzKernel := @HorzKernel; FloorKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Int]^; {$IFDEF HAS_NATIVEINT} CeilKernel := PKernelEntry(NativeUInt(FloorKernel) + J); {$ELSE} CeilKernel := PKernelEntry(Cardinal(FloorKernel) + J); {$ENDIF} Dev := -256; for I := -KWidth to KWidth do begin Wv := FloorKernel[I] + ((CeilKernel[I] - FloorKernel[I]) * Frac + $7FFF) div FixedOne; HorzKernel[I] := Wv; Inc(Dev, Wv); end; Dec(HorzKernel[0], Dev); end; with TFixedRec(FracY) do begin Fixed := Round((clY - Y) * W); PVertKernel := @VertKernel; FloorKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Int]^; {$IFDEF HAS_NATIVEINT} CeilKernel := PKernelEntry(NativeUInt(FloorKernel) + J); {$ELSE} CeilKernel := PKernelEntry(Cardinal(FloorKernel) + J); {$ENDIF} Dev := -256; for I := -KWidth to KWidth do begin Wv := FloorKernel[I] + ((CeilKernel[I] - FloorKernel[I]) * Frac + $7FFF) div FixedOne; VertKernel[I] := Wv; Inc(Dev, Wv); end; Dec(VertKernel[0], Dev); end; end; end; VertEntry := EMPTY_ENTRY; case PixelAccessMode of pamUnsafe, pamSafe, pamTransparentEdge: begin SrcP := PColor32Entry(Bitmap.PixelPtr[LoX + clX, LoY + clY]); Incr := Bitmap.Width - (HiX - LoX) - 1; for I := LoY to HiY do begin Wv := PVertKernel[I]; if Wv <> 0 then begin HorzEntry := EMPTY_ENTRY; for J := LoX to HiX do begin // Alpha=0 should not contribute to sample. Alpha := SrcP.A; if (Alpha <> 0) then begin W := PHorzKernel[J]; Inc(HorzEntry.A, Alpha * W); // Sample premultiplied values if (Alpha = 255) then begin Inc(HorzEntry.R, SrcP.R * W); Inc(HorzEntry.G, SrcP.G * W); Inc(HorzEntry.B, SrcP.B * W); end else begin Inc(HorzEntry.R, Integer(Div255(Alpha * SrcP.R)) * W); Inc(HorzEntry.G, Integer(Div255(Alpha * SrcP.G)) * W); Inc(HorzEntry.B, Integer(Div255(Alpha * SrcP.B)) * W); end; end; Inc(SrcP); end; Inc(VertEntry.A, HorzEntry.A * Wv); Inc(VertEntry.R, HorzEntry.R * Wv); Inc(VertEntry.G, HorzEntry.G * Wv); Inc(VertEntry.B, HorzEntry.B * Wv); end else Inc(SrcP, HiX - LoX + 1); Inc(SrcP, Incr); end; if (PixelAccessMode = pamSafe) and Edge then begin Alpha := TColor32Entry(FOuterColor).A; // Alpha=0 should not contribute to sample. if (Alpha <> 0) then begin // Sample premultiplied values OuterPremultColorR := Integer(Div255(Alpha * TColor32Entry(FOuterColor).R)); OuterPremultColorG := Integer(Div255(Alpha * TColor32Entry(FOuterColor).G)); OuterPremultColorB := Integer(Div255(Alpha * TColor32Entry(FOuterColor).B)); for I := -KWidth to KWidth do begin Wv := PVertKernel[I]; if Wv <> 0 then begin HorzEntry := EMPTY_ENTRY; for J := -KWidth to KWidth do if (J < LoX) or (J > HiX) or (I < LoY) or (I > HiY) then begin W := PHorzKernel[J]; Inc(HorzEntry.A, Alpha * W); Inc(HorzEntry.R, OuterPremultColorR * W); Inc(HorzEntry.G, OuterPremultColorG * W); Inc(HorzEntry.B, OuterPremultColorB * W); end; Inc(VertEntry.A, HorzEntry.A * Wv); Inc(VertEntry.R, HorzEntry.R * Wv); Inc(VertEntry.G, HorzEntry.G * Wv); Inc(VertEntry.B, HorzEntry.B * Wv); end; end end; end; end; pamWrap: begin WrapProcHorz := GetWrapProcEx(Bitmap.WrapMode, ClipRect.Left, ClipRect.Right - 1); WrapProcVert := GetWrapProcEx(Bitmap.WrapMode, ClipRect.Top, ClipRect.Bottom - 1); for I := -KWidth to KWidth do MappingX[I] := WrapProcHorz(clX + I, ClipRect.Left, ClipRect.Right - 1); for I := -KWidth to KWidth do begin Wv := PVertKernel[I]; if Wv <> 0 then begin MappingY := WrapProcVert(clY + I, ClipRect.Top, ClipRect.Bottom - 1); Colors := PColor32EntryArray(Bitmap.ScanLine[MappingY]); HorzEntry := EMPTY_ENTRY; for J := -KWidth to KWidth do begin C := Colors[MappingX[J]]; Alpha := C.A; // Alpha=0 should not contribute to sample. if (Alpha <> 0) then begin W := PHorzKernel[J]; Inc(HorzEntry.A, Alpha * W); // Sample premultiplied values if (Alpha = 255) then begin Inc(HorzEntry.R, C.R * W); Inc(HorzEntry.G, C.G * W); Inc(HorzEntry.B, C.B * W); end else begin Inc(HorzEntry.R, Div255(Alpha * C.R) * W); Inc(HorzEntry.G, Div255(Alpha * C.G) * W); Inc(HorzEntry.B, Div255(Alpha * C.B) * W); end; end; end; Inc(VertEntry.A, HorzEntry.A * Wv); Inc(VertEntry.R, HorzEntry.R * Wv); Inc(VertEntry.G, HorzEntry.G * Wv); Inc(VertEntry.B, HorzEntry.B * Wv); end; end; end; end; // Round and unpremultiply result with TColor32Entry(Result) do begin if FKernel.RangeCheck then begin A := Clamp(TFixedRec(Integer(VertEntry.A + FixedHalf)).Int); if (A = 255) then begin R := Clamp(TFixedRec(Integer(VertEntry.R + FixedHalf)).Int); G := Clamp(TFixedRec(Integer(VertEntry.G + FixedHalf)).Int); B := Clamp(TFixedRec(Integer(VertEntry.B + FixedHalf)).Int); end else if (A <> 0) then begin R := Clamp(TFixedRec(Integer(VertEntry.R + FixedHalf)).Int * 255 div A); G := Clamp(TFixedRec(Integer(VertEntry.G + FixedHalf)).Int * 255 div A); B := Clamp(TFixedRec(Integer(VertEntry.B + FixedHalf)).Int * 255 div A); end else begin R := 0; G := 0; B := 0; end; end else begin A := TFixedRec(Integer(VertEntry.A + FixedHalf)).Int; if (A = 255) then begin R := TFixedRec(Integer(VertEntry.R + FixedHalf)).Int; G := TFixedRec(Integer(VertEntry.G + FixedHalf)).Int; B := TFixedRec(Integer(VertEntry.B + FixedHalf)).Int; end else if (A <> 0) then begin R := TFixedRec(Integer(VertEntry.R + FixedHalf)).Int * 255 div A; G := TFixedRec(Integer(VertEntry.G + FixedHalf)).Int * 255 div A; B := TFixedRec(Integer(VertEntry.B + FixedHalf)).Int * 255 div A; end else begin R := 0; G := 0; B := 0; end; end; end; end; {$WARNINGS ON} function TKernelResampler.GetWidth: TFloat; begin Result := Kernel.GetWidth; end; procedure TKernelResampler.SetKernelMode(const Value: TKernelMode); begin if FKernelMode <> Value then begin FKernelMode := Value; Changed; end; end; procedure TKernelResampler.SetTableSize(Value: Integer); begin if Value < 2 then Value := 2; if FTableSize <> Value then begin FTableSize := Value; Changed; end; end; procedure TKernelResampler.FinalizeSampling; begin if FKernelMode in [kmTableNearest, kmTableLinear] then FWeightTable.Free; inherited; end; procedure TKernelResampler.PrepareSampling; var I, J, W, Weight, Dev: Integer; Fraction: TFloat; KernelPtr: PKernelEntry; begin inherited; FOuterColor := Bitmap.OuterColor; W := Ceil(FKernel.GetWidth); if FKernelMode in [kmTableNearest, kmTableLinear] then begin FWeightTable := TIntegerMap.Create(W * 2 + 1, FTableSize + 1); for I := 0 to FTableSize do begin Fraction := I / (FTableSize - 1); KernelPtr := @FWeightTable.ValPtr[W - MAX_KERNEL_WIDTH, I]^; Dev := - 256; for J := -W to W do begin Weight := Round(FKernel.Filter(J + Fraction) * 256); KernelPtr[J] := Weight; Inc(Dev, Weight); end; Dec(KernelPtr[0], Dev); end; end; end; { TCustomBitmap32NearestResampler } function TNearestResampler.GetSampleInt(X, Y: Integer): TColor32; begin Result := FGetSampleInt(X, Y); end; function TNearestResampler.GetSampleFixed(X, Y: TFixed): TColor32; begin Result := FGetSampleInt(FixedRound(X), FixedRound(Y)); end; function TNearestResampler.GetSampleFloat(X, Y: TFloat): TColor32; begin Result := FGetSampleInt(Round(X), Round(Y)); end; function TNearestResampler.GetWidth: TFloat; begin Result := 1; end; function TNearestResampler.GetPixelTransparentEdge(X,Y: Integer): TColor32; var I, J: Integer; begin with Bitmap, Bitmap.ClipRect do begin I := Clamp(X, Left, Right - 1); J := Clamp(Y, Top, Bottom - 1); Result := Pixel[I, J]; if (I <> X) or (J <> Y) then Result := Result and $00FFFFFF; end; end; procedure TNearestResampler.PrepareSampling; begin inherited; case PixelAccessMode of pamUnsafe: FGetSampleInt := TCustomBitmap32Access(Bitmap).GetPixel; pamSafe: FGetSampleInt := TCustomBitmap32Access(Bitmap).GetPixelS; pamWrap: FGetSampleInt := TCustomBitmap32Access(Bitmap).GetPixelW; pamTransparentEdge: FGetSampleInt := GetPixelTransparentEdge; end; end; procedure TNearestResampler.Resample( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); begin StretchNearest(Dst, DstRect, DstClip, Src, SrcRect, CombineOp, CombineCallBack) end; { TCustomBitmap32LinearResampler } constructor TLinearResampler.Create; begin inherited; FLinearKernel := TLinearKernel.Create; end; destructor TLinearResampler.Destroy; begin FLinearKernel.Free; inherited Destroy; end; function TLinearResampler.GetSampleFixed(X, Y: TFixed): TColor32; begin Result := FGetSampleFixed(X, Y); end; function TLinearResampler.GetSampleFloat(X, Y: TFloat): TColor32; begin Result := FGetSampleFixed(Round(X * FixedOne), Round(Y * FixedOne)); end; function TLinearResampler.GetPixelTransparentEdge(X, Y: TFixed): TColor32; var I, J, X1, X2, Y1, Y2, WX, R, B: TFixed; C1, C2, C3, C4: TColor32; PSrc: PColor32Array; begin with TCustomBitmap32Access(Bitmap), Bitmap.ClipRect do begin R := Right - 1; B := Bottom - 1; I := TFixedRec(X).Int; J := TFixedRec(Y).Int; if (I >= Left) and (J >= Top) and (I < R) and (J < B) then begin //Safe Result := GET_T256(X shr 8, Y shr 8); EMMS; end else if (I >= Left - 1) and (J >= Top - 1) and (I <= R) and (J <= B) then begin //Near edge, on edge or outside X1 := Clamp(I, R); X2 := Clamp(I + Sign(X), R); Y1 := Clamp(J, B) * Width; Y2 := Clamp(J + Sign(Y), B) * Width; PSrc := @Bits[0]; C1 := PSrc[X1 + Y1]; C2 := PSrc[X2 + Y1]; C3 := PSrc[X1 + Y2]; C4 := PSrc[X2 + Y2]; if X <= Fixed(Left) then begin C1 := C1 and $00FFFFFF; C3 := C3 and $00FFFFFF; end else if I = R then begin C2 := C2 and $00FFFFFF; C4 := C4 and $00FFFFFF; end; if Y <= Fixed(Top) then begin C1 := C1 and $00FFFFFF; C2 := C2 and $00FFFFFF; end else if J = B then begin C3 := C3 and $00FFFFFF; C4 := C4 and $00FFFFFF; end; WX := GAMMA_TABLE[((X shr 8) and $FF) xor $FF]; Result := CombineReg(CombineReg(C1, C2, WX), CombineReg(C3, C4, WX), GAMMA_TABLE[((Y shr 8) and $FF) xor $FF]); EMMS; end else Result := 0; //Nothing really makes sense here, return zero end; end; procedure TLinearResampler.PrepareSampling; begin inherited; case PixelAccessMode of pamUnsafe: FGetSampleFixed := TCustomBitmap32Access(Bitmap).GetPixelX; pamSafe: FGetSampleFixed := TCustomBitmap32Access(Bitmap).GetPixelXS; pamWrap: FGetSampleFixed := TCustomBitmap32Access(Bitmap).GetPixelXW; pamTransparentEdge: FGetSampleFixed := GetPixelTransparentEdge; end; end; function TLinearResampler.GetWidth: TFloat; begin Result := 1; end; procedure TLinearResampler.Resample( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); var SrcW, SrcH: TFloat; DstW, DstH: Integer; begin SrcW := SrcRect.Right - SrcRect.Left; SrcH := SrcRect.Bottom - SrcRect.Top; DstW := DstRect.Right - DstRect.Left; DstH := DstRect.Bottom - DstRect.Top; if (DstW > SrcW) and (DstH > SrcH) and (SrcW > 1) and (SrcH > 1) then StretchHorzStretchVertLinear(Dst, DstRect, DstClip, Src, SrcRect, CombineOp, CombineCallBack) else GR32_Resamplers.Resample(Dst, DstRect, DstClip, Src, SrcRect, FLinearKernel, CombineOp, CombineCallBack); end; procedure TDraftResampler.Resample( Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); begin DraftResample(Dst, DstRect, DstClip, Src, SrcRect, FLinearKernel, CombineOp, CombineCallBack) end; { TTransformer } function TTransformer.GetSampleInt(X, Y: Integer): TColor32; var U, V: TFixed; begin FTransformationReverseTransformFixed(X * FixedOne + FixedHalf, Y * FixedOne + FixedHalf, U, V); Result := FGetSampleFixed(U - FixedHalf, V - FixedHalf); end; function TTransformer.GetSampleFixed(X, Y: TFixed): TColor32; var U, V: TFixed; begin FTransformationReverseTransformFixed(X + FixedHalf, Y + FixedHalf, U, V); Result := FGetSampleFixed(U - FixedHalf, V - FixedHalf); end; function TTransformer.GetSampleFloat(X, Y: TFloat): TColor32; var U, V: TFloat; begin FTransformationReverseTransformFloat(X + 0.5, Y + 0.5, U, V); Result := FGetSampleFloat(U - 0.5, V - 0.5); end; procedure TTransformer.SetTransformation(const Value: TTransformation); begin FTransformation := Value; if Assigned(Value) then begin FTransformationReverseTransformInt := TTransformationAccess(FTransformation).ReverseTransformInt; FTransformationReverseTransformFixed := TTransformationAccess(FTransformation).ReverseTransformFixed; FTransformationReverseTransformFloat := TTransformationAccess(FTransformation).ReverseTransformFloat; end; end; constructor TTransformer.Create(ASampler: TCustomSampler; ATransformation: TTransformation); begin inherited Create(ASampler); Transformation := ATransformation; end; procedure TTransformer.PrepareSampling; begin inherited; with TTransformationAccess(FTransformation) do if not TransformValid then PrepareTransform; end; function TTransformer.GetSampleBounds: TFloatRect; begin IntersectRect(Result, inherited GetSampleBounds, FTransformation.SrcRect); Result := FTransformation.GetTransformedBounds(Result); end; function TTransformer.HasBounds: Boolean; begin Result := FTransformation.HasTransformedBounds and inherited HasBounds; end; { TSuperSampler } constructor TSuperSampler.Create(Sampler: TCustomSampler); begin inherited Create(Sampler); FSamplingX := 4; FSamplingY := 4; SamplingX := 4; SamplingY := 4; end; function TSuperSampler.GetSampleFixed(X, Y: TFixed): TColor32; var I, J: Integer; dX, dY, tX: TFixed; Buffer: TBufferEntry; begin Buffer := EMPTY_ENTRY; tX := X + FOffsetX; Inc(Y, FOffsetY); dX := FDistanceX; dY := FDistanceY; for J := 1 to FSamplingY do begin X := tX; for I := 1 to FSamplingX do begin IncBuffer(Buffer, FGetSampleFixed(X, Y)); Inc(X, dX); end; Inc(Y, dY); end; MultiplyBuffer(Buffer, FScale); Result := BufferToColor32(Buffer, 16); end; procedure TSuperSampler.SetSamplingX(const Value: TSamplingRange); begin FSamplingX := Value; FDistanceX := Fixed(1 / Value); FOffsetX := Fixed(((1 / Value) - 1) * 0.5); // replaced "/2" by "*0.5" FScale := Fixed(1 / (FSamplingX * FSamplingY)); end; procedure TSuperSampler.SetSamplingY(const Value: TSamplingRange); begin FSamplingY := Value; FDistanceY := Fixed(1 / Value); FOffsetY := Fixed(((1 / Value) - 1) * 0.5); // replaced "/2" by "*0.5" FScale := Fixed(1 / (FSamplingX * FSamplingY)); end; { TAdaptiveSuperSampler } function TAdaptiveSuperSampler.CompareColors(C1, C2: TColor32): Boolean; var Diff: TColor32Entry; begin Diff.ARGB := ColorDifference(C1, C2); Result := FTolerance < Diff.R + Diff.G + Diff.B; end; constructor TAdaptiveSuperSampler.Create(Sampler: TCustomSampler); begin inherited Create(Sampler); Level := 4; Tolerance := 256; end; function TAdaptiveSuperSampler.DoRecurse(X, Y, Offset: TFixed; const A, B, C, D, E: TColor32): TColor32; var C1, C2, C3, C4: TColor32; begin C1 := QuadrantColor(A, E, X - Offset, Y - Offset, Offset, RecurseAC); C2 := QuadrantColor(B, E, X + Offset, Y - Offset, Offset, RecurseBD); C3 := QuadrantColor(E, C, X + Offset, Y + Offset, Offset, RecurseAC); C4 := QuadrantColor(E, D, X - Offset, Y + Offset, Offset, RecurseBD); Result := ColorAverage(ColorAverage(C1, C2), ColorAverage(C3, C4)); end; function TAdaptiveSuperSampler.GetSampleFixed(X, Y: TFixed): TColor32; var A, B, C, D, E: TColor32; const FIXED_HALF = 32768; begin A := FGetSampleFixed(X - FIXED_HALF, Y - FIXED_HALF); B := FGetSampleFixed(X + FIXED_HALF, Y - FIXED_HALF); C := FGetSampleFixed(X + FIXED_HALF, Y + FIXED_HALF); D := FGetSampleFixed(X - FIXED_HALF, Y + FIXED_HALF); E := FGetSampleFixed(X, Y); Result := Self.DoRecurse(X, Y, 16384, A, B, C, D, E); EMMS; end; function TAdaptiveSuperSampler.QuadrantColor(const C1, C2: TColor32; X, Y, Offset: TFixed; Proc: TRecurseProc): TColor32; begin if CompareColors(C1, C2) and (Offset >= FMinOffset) then Result := Proc(X, Y, Offset, C1, C2) else Result := ColorAverage(C1, C2); end; function TAdaptiveSuperSampler.RecurseAC(X, Y, Offset: TFixed; const A, C: TColor32): TColor32; var B, D, E: TColor32; begin EMMS; B := FGetSampleFixed(X + Offset, Y - Offset); D := FGetSampleFixed(X - Offset, Y + Offset); E := FGetSampleFixed(X, Y); Result := DoRecurse(X, Y, Offset shr 1, A, B, C, D, E); end; function TAdaptiveSuperSampler.RecurseBD(X, Y, Offset: TFixed; const B, D: TColor32): TColor32; var A, C, E: TColor32; begin EMMS; A := FGetSampleFixed(X - Offset, Y - Offset); C := FGetSampleFixed(X + Offset, Y + Offset); E := FGetSampleFixed(X, Y); Result := DoRecurse(X, Y, Offset shr 1, A, B, C, D, E); end; procedure TAdaptiveSuperSampler.SetLevel(const Value: Integer); begin FLevel := Value; FMinOffset := Fixed(1 / (1 shl Value)); end; { TPatternSampler } destructor TPatternSampler.Destroy; begin if Assigned(FPattern) then FPattern := nil; inherited; end; function TPatternSampler.GetSampleFixed(X, Y: TFixed): TColor32; var Points: TArrayOfFixedPoint; P: PFixedPoint; I, PY: Integer; Buffer: TBufferEntry; GetSample: TGetSampleFixed; WrapProcHorz: TWrapProc; begin GetSample := FSampler.GetSampleFixed; PY := WrapProcVert(TFixedRec(Y).Int, High(FPattern)); I := High(FPattern[PY]); WrapProcHorz := GetOptimalWrap(I); Points := FPattern[PY][WrapProcHorz(TFixedRec(X).Int, I)]; Buffer := EMPTY_ENTRY; P := @Points[0]; for I := 0 to High(Points) do begin IncBuffer(Buffer, GetSample(P.X + X, P.Y + Y)); Inc(P); end; MultiplyBuffer(Buffer, FixedOne div Length(Points)); Result := BufferToColor32(Buffer, 16); end; procedure TPatternSampler.SetPattern(const Value: TFixedSamplePattern); begin if Assigned(Value) then begin FPattern := nil; FPattern := Value; WrapProcVert := GetOptimalWrap(High(FPattern)); end; end; function JitteredPattern(XRes, YRes: Integer): TArrayOfFixedPoint; var I, J: Integer; begin SetLength(Result, XRes * YRes); for I := 0 to XRes - 1 do for J := 0 to YRes - 1 do with Result[I + J * XRes] do begin X := (Random(65536) + I * 65536) div XRes - 32768; Y := (Random(65536) + J * 65536) div YRes - 32768; end; end; function CreateJitteredPattern(TileWidth, TileHeight, SamplesX, SamplesY: Integer): TFixedSamplePattern; var I, J: Integer; begin SetLength(Result, TileHeight, TileWidth); for I := 0 to TileWidth - 1 do for J := 0 to TileHeight - 1 do Result[J][I] := JitteredPattern(SamplesX, SamplesY); end; procedure RegisterResampler(ResamplerClass: TCustomResamplerClass); begin if not Assigned(ResamplerList) then ResamplerList := TClassList.Create; ResamplerList.ADD(ResamplerClass); end; procedure RegisterKernel(KernelClass: TCustomKernelClass); begin if not Assigned(KernelList) then KernelList := TClassList.Create; KernelList.ADD(KernelClass); end; { TNestedSampler } procedure TNestedSampler.AssignTo(Dst: TPersistent); begin if Dst is TNestedSampler then SmartAssign(Self, Dst) else inherited; end; constructor TNestedSampler.Create(ASampler: TCustomSampler); begin inherited Create; Sampler := ASampler; end; procedure TNestedSampler.FinalizeSampling; begin if not Assigned(FSampler) then raise ENestedException.Create(SSamplerNil) else FSampler.FinalizeSampling; end; {$WARNINGS OFF} function TNestedSampler.GetSampleBounds: TFloatRect; begin if not Assigned(FSampler) then raise ENestedException.Create(SSamplerNil) else Result := FSampler.GetSampleBounds; end; function TNestedSampler.HasBounds: Boolean; begin if not Assigned(FSampler) then raise ENestedException.Create(SSamplerNil) else Result := FSampler.HasBounds; end; {$WARNINGS ON} procedure TNestedSampler.PrepareSampling; begin if not Assigned(FSampler) then raise ENestedException.Create(SSamplerNil) else FSampler.PrepareSampling; end; procedure TNestedSampler.SetSampler(const Value: TCustomSampler); begin FSampler := Value; if Assigned(Value) then begin FGetSampleInt := FSampler.GetSampleInt; FGetSampleFixed := FSampler.GetSampleFixed; FGetSampleFloat := FSampler.GetSampleFloat; end; end; { TKernelSampler } function TKernelSampler.ConvertBuffer(var Buffer: TBufferEntry): TColor32; begin Buffer.A := Constrain(Buffer.A, 0, $FFFF); Buffer.R := Constrain(Buffer.R, 0, $FFFF); Buffer.G := Constrain(Buffer.G, 0, $FFFF); Buffer.B := Constrain(Buffer.B, 0, $FFFF); Result := BufferToColor32(Buffer, 8); end; constructor TKernelSampler.Create(ASampler: TCustomSampler); begin inherited; FKernel := TIntegerMap.Create; FStartEntry := EMPTY_ENTRY; end; destructor TKernelSampler.Destroy; begin FKernel.Free; inherited; end; function TKernelSampler.GetSampleFixed(X, Y: TFixed): TColor32; var I, J: Integer; Buffer: TBufferEntry; begin X := X + FCenterX shl 16; Y := Y + FCenterY shl 16; Buffer := FStartEntry; for I := 0 to FKernel.Width - 1 do for J := 0 to FKernel.Height - 1 do UpdateBuffer(Buffer, FGetSampleFixed(X - I shl 16, Y - J shl 16), FKernel[I, J]); Result := ConvertBuffer(Buffer); end; function TKernelSampler.GetSampleInt(X, Y: Integer): TColor32; var I, J: Integer; Buffer: TBufferEntry; begin X := X + FCenterX; Y := Y + FCenterY; Buffer := FStartEntry; for I := 0 to FKernel.Width - 1 do for J := 0 to FKernel.Height - 1 do UpdateBuffer(Buffer, FGetSampleInt(X - I, Y - J), FKernel[I, J]); Result := ConvertBuffer(Buffer); end; { TConvolver } procedure TConvolver.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); begin with TColor32Entry(Color) do begin Inc(Buffer.A, A * Weight); Inc(Buffer.R, R * Weight); Inc(Buffer.G, G * Weight); Inc(Buffer.B, B * Weight); end; end; { TDilater } procedure TDilater.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); begin with TColor32Entry(Color) do begin Buffer.A := Max(Buffer.A, A + Weight); Buffer.R := Max(Buffer.R, R + Weight); Buffer.G := Max(Buffer.G, G + Weight); Buffer.B := Max(Buffer.B, B + Weight); end; end; { TEroder } constructor TEroder.Create(ASampler: TCustomSampler); const START_ENTRY: TBufferEntry = (B: $FFFF; G: $FFFF; R: $FFFF; A: $FFFF); begin inherited; FStartEntry := START_ENTRY; end; procedure TEroder.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); begin with TColor32Entry(Color) do begin Buffer.A := Min(Buffer.A, A - Weight); Buffer.R := Min(Buffer.R, R - Weight); Buffer.G := Min(Buffer.G, G - Weight); Buffer.B := Min(Buffer.B, B - Weight); end; end; { TExpander } procedure TExpander.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); begin with TColor32Entry(Color) do begin Buffer.A := Max(Buffer.A, A * Weight); Buffer.R := Max(Buffer.R, R * Weight); Buffer.G := Max(Buffer.G, G * Weight); Buffer.B := Max(Buffer.B, B * Weight); end; end; { TContracter } function TContracter.GetSampleFixed(X, Y: TFixed): TColor32; begin Result := ColorSub(FMaxWeight, inherited GetSampleFixed(X, Y)); end; function TContracter.GetSampleInt(X, Y: Integer): TColor32; begin Result := ColorSub(FMaxWeight, inherited GetSampleInt(X, Y)); end; procedure TContracter.PrepareSampling; var I, J, W: Integer; begin W := Low(Integer); for I := 0 to FKernel.Width - 1 do for J := 0 to FKernel.Height - 1 do W := Max(W, FKernel[I, J]); if W > 255 then W := 255; FMaxWeight := Gray32(W, W); end; procedure TContracter.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); begin inherited UpdateBuffer(Buffer, Color xor $FFFFFFFF, Weight); end; { TMorphologicalSampler } function TMorphologicalSampler.ConvertBuffer( var Buffer: TBufferEntry): TColor32; begin Buffer.A := Constrain(Buffer.A, 0, $FF); Buffer.R := Constrain(Buffer.R, 0, $FF); Buffer.G := Constrain(Buffer.G, 0, $FF); Buffer.B := Constrain(Buffer.B, 0, $FF); with TColor32Entry(Result) do begin A := Buffer.A; R := Buffer.R; G := Buffer.G; B := Buffer.B; end; end; { TSelectiveConvolver } function TSelectiveConvolver.ConvertBuffer(var Buffer: TBufferEntry): TColor32; begin with TColor32Entry(Result) do begin A := Buffer.A div FWeightSum.A; R := Buffer.R div FWeightSum.R; G := Buffer.G div FWeightSum.G; B := Buffer.B div FWeightSum.B; end; end; constructor TSelectiveConvolver.Create(ASampler: TCustomSampler); begin inherited; FDelta := 30; end; function TSelectiveConvolver.GetSampleFixed(X, Y: TFixed): TColor32; begin FRefColor := FGetSampleFixed(X, Y); FWeightSum := EMPTY_ENTRY; Result := inherited GetSampleFixed(X, Y); end; function TSelectiveConvolver.GetSampleInt(X, Y: Integer): TColor32; begin FRefColor := FGetSampleInt(X, Y); FWeightSum := EMPTY_ENTRY; Result := inherited GetSampleInt(X, Y); end; procedure TSelectiveConvolver.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32; Weight: Integer); begin with TColor32Entry(Color) do begin if Abs(TColor32Entry(FRefColor).A - A) <= FDelta then begin Inc(Buffer.A, A * Weight); Inc(FWeightSum.A, Weight); end; if Abs(TColor32Entry(FRefColor).R - R) <= FDelta then begin Inc(Buffer.R, R * Weight); Inc(FWeightSum.R, Weight); end; if Abs(TColor32Entry(FRefColor).G - G) <= FDelta then begin Inc(Buffer.G, G * Weight); Inc(FWeightSum.G, Weight); end; if Abs(TColor32Entry(FRefColor).B - B) <= FDelta then begin Inc(Buffer.B, B * Weight); Inc(FWeightSum.B, Weight); end; end; end; {CPU target and feature function templates} const FID_BLOCKAVERAGE = 0; FID_INTERPOLATOR = 1; var Registry: TFunctionRegistry; procedure RegisterBindings; begin Registry := NewRegistry('GR32_Resamplers bindings'); Registry.RegisterBinding(FID_BLOCKAVERAGE, @@BlockAverage); Registry.RegisterBinding(FID_INTERPOLATOR, @@Interpolator); Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_Pas); Registry.ADD(FID_INTERPOLATOR, @Interpolator_Pas); {$IFNDEF PUREPASCAL} Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_MMX, [ciMMX]); {$IFDEF USE_3DNOW} Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_3DNow, [ci3DNow]); {$ENDIF} Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_SSE2, [ciSSE2]); Registry.ADD(FID_INTERPOLATOR, @Interpolator_MMX, [ciMMX, ciSSE]); Registry.ADD(FID_INTERPOLATOR, @Interpolator_SSE2, [ciSSE2]); {$ENDIF} Registry.RebindAll; end; initialization RegisterBindings; { Register resamplers } RegisterResampler(TNearestResampler); RegisterResampler(TLinearResampler); RegisterResampler(TDraftResampler); RegisterResampler(TKernelResampler); { Register kernels } RegisterKernel(TBoxKernel); RegisterKernel(TLinearKernel); RegisterKernel(TCosineKernel); RegisterKernel(TSplineKernel); RegisterKernel(TCubicKernel); RegisterKernel(TMitchellKernel); RegisterKernel(TAlbrechtKernel); RegisterKernel(TLanczosKernel); RegisterKernel(TGaussianKernel); RegisterKernel(TBlackmanKernel); RegisterKernel(THannKernel); RegisterKernel(THammingKernel); RegisterKernel(TSinshKernel); RegisterKernel(THermiteKernel); finalization ResamplerList.Free; KernelList.Free; end. |
Added src/graphics32/GR32_System.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 | unit GR32_System; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Andre Beckedorf * Michael Hansen <dyster_tid@hotmail.com> * - CPU type & feature-set aware function binding * - Runtime function template and extension binding system * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LCLType, {$IFDEF Windows} Windows, {$ENDIF} {$IFDEF UNIX} Unix, BaseUnix, {$ENDIF} {$ELSE} Windows, {$ENDIF} SysUtils; type TPerfTimer = class private {$IFDEF UNIX} {$IFDEF FPC} FStart: Int64; {$ENDIF} {$ENDIF} {$IFDEF Windows} FFrequency, FPerformanceCountStart, FPerformanceCountStop: Int64; {$ENDIF} public procedure Start; function ReadNanoseconds: string; function ReadMilliseconds: string; function ReadSeconds: string; function ReadValue: Int64; end; { Pseudo GetTickCount implementation for Linux - for compatibility This works for basic time testing, however, it doesnt work like its Windows counterpart, ie. it doesnt return the number of milliseconds since system boot. Will definitely overflow. } function GetTickCount: Cardinal; { Returns the number of processors configured by the operating system. } function GetProcessorCount: Cardinal; type {$IFNDEF PUREPASCAL} { TCPUInstructionSet, defines specific CPU technologies } TCPUInstructionSet = (ciMMX, ciEMMX, ciSSE, ciSSE2, ci3DNow, ci3DNowExt); {$ELSE} TCPUInstructionSet = (ciDummy); {$DEFINE NO_REQUIREMENTS} {$ENDIF} PCPUFeatures = ^TCPUFeatures; TCPUFeatures = set of TCPUInstructionSet; { General function that returns whether a particular instruction set is supported for the current CPU or not } function HasInstructionSet(const InstructionSet: TCPUInstructionSet): Boolean; function CPUFeatures: TCPUFeatures; var GlobalPerfTimer: TPerfTimer; implementation uses Forms, Classes, TypInfo; var CPUFeaturesInitialized : Boolean = False; CPUFeaturesData: TCPUFeatures; {$IFDEF UNIX} {$IFDEF FPC} function GetTickCount: Cardinal; var t : timeval; begin fpgettimeofday(@t,nil); // Build a 64 bit microsecond tick from the seconds and microsecond longints Result := (Int64(t.tv_sec) * 1000000) + t.tv_usec; end; { TPerfTimer } function TPerfTimer.ReadNanoseconds: string; begin Result := IntToStr(ReadValue); end; function TPerfTimer.ReadMilliseconds: string; begin Result := IntToStr(ReadValue div 1000); end; function TPerfTimer.ReadSeconds: string; begin Result := IntToStr(ReadValue div 1000000); end; function TPerfTimer.ReadValue: Int64; begin Result := GetTickCount - FStart; end; procedure TPerfTimer.Start; begin FStart := GetTickCount; end; {$ENDIF} {$ENDIF} {$IFDEF Windows} function GetTickCount: Cardinal; begin Result := Windows.GetTickCount; end; { TPerfTimer } function TPerfTimer.ReadNanoseconds: string; begin QueryPerformanceCounter(FPerformanceCountStop); QueryPerformanceFrequency(FFrequency); Assert(FFrequency > 0); Result := IntToStr(Round(1000000 * (FPerformanceCountStop - FPerformanceCountStart) / FFrequency)); end; function TPerfTimer.ReadMilliseconds: string; begin QueryPerformanceCounter(FPerformanceCountStop); QueryPerformanceFrequency(FFrequency); Assert(FFrequency > 0); Result := FloatToStrF(1000 * (FPerformanceCountStop - FPerformanceCountStart) / FFrequency, ffFixed, 15, 3); end; function TPerfTimer.ReadSeconds: String; begin QueryPerformanceCounter(FPerformanceCountStop); QueryPerformanceFrequency(FFrequency); Result := FloatToStrF((FPerformanceCountStop - FPerformanceCountStart) / FFrequency, ffFixed, 15, 3); end; function TPerfTimer.ReadValue: Int64; begin QueryPerformanceCounter(FPerformanceCountStop); QueryPerformanceFrequency(FFrequency); Assert(FFrequency > 0); Result := Round(1000000 * (FPerformanceCountStop - FPerformanceCountStart) / FFrequency); end; procedure TPerfTimer.Start; begin QueryPerformanceCounter(FPerformanceCountStart); end; {$ENDIF} {$IFDEF UNIX} {$IFDEF FPC} function GetProcessorCount: Cardinal; begin Result := 1; end; {$ENDIF} {$ENDIF} {$IFDEF Windows} function GetProcessorCount: Cardinal; var lpSysInfo: TSystemInfo; begin GetSystemInfo(lpSysInfo); Result := lpSysInfo.dwNumberOfProcessors; end; {$ENDIF} {$IFNDEF PUREPASCAL} const CPUISChecks: array [TCPUInstructionSet] of Cardinal = ($800000, $400000, $2000000, $4000000, $80000000, $40000000); {ciMMX , ciEMMX, ciSSE , ciSSE2 , ci3DNow , ci3DNowExt} function CPUID_Available: Boolean; asm {$IFDEF TARGET_x86} MOV EDX,False PUSHFD POP EAX MOV ECX,EAX XOR EAX,$00200000 PUSH EAX POPFD PUSHFD POP EAX XOR ECX,EAX JZ @1 MOV EDX,True @1: PUSH EAX POPFD MOV EAX,EDX {$ENDIF} {$IFDEF TARGET_x64} MOV EDX,False PUSHFQ POP RAX MOV ECX,EAX XOR EAX,$00200000 PUSH RAX POPFQ PUSHFQ POP RAX XOR ECX,EAX JZ @1 MOV EDX,True @1: PUSH RAX POPFQ MOV EAX,EDX {$ENDIF} end; function CPU_Signature: Integer; asm {$IFDEF TARGET_x86} PUSH EBX MOV EAX,1 {$IFDEF FPC} CPUID {$ELSE} DW $A20F // CPUID {$ENDIF} POP EBX {$ENDIF} {$IFDEF TARGET_x64} PUSH RBX MOV EAX,1 CPUID POP RBX {$ENDIF} end; function CPU_Features: Integer; asm {$IFDEF TARGET_x86} PUSH EBX MOV EAX,1 {$IFDEF FPC} CPUID {$ELSE} DW $A20F // CPUID {$ENDIF} POP EBX MOV EAX,EDX {$ENDIF} {$IFDEF TARGET_x64} PUSH RBX MOV EAX,1 CPUID POP RBX MOV EAX,EDX {$ENDIF} end; function CPU_ExtensionsAvailable: Boolean; asm {$IFDEF TARGET_x86} PUSH EBX MOV @Result, True MOV EAX, $80000000 {$IFDEF FPC} CPUID {$ELSE} DW $A20F // CPUID {$ENDIF} CMP EAX, $80000000 JBE @NOEXTENSION JMP @EXIT @NOEXTENSION: MOV @Result, False @EXIT: POP EBX {$ENDIF} {$IFDEF TARGET_x64} PUSH RBX MOV @Result, True MOV EAX, $80000000 CPUID CMP EAX, $80000000 JBE @NOEXTENSION JMP @EXIT @NOEXTENSION: MOV @Result, False @EXIT: POP RBX {$ENDIF} end; function CPU_ExtFeatures: Integer; asm {$IFDEF TARGET_x86} PUSH EBX MOV EAX, $80000001 {$IFDEF FPC} CPUID {$ELSE} DW $A20F // CPUID {$ENDIF} POP EBX MOV EAX,EDX {$ENDIF} {$IFDEF TARGET_x64} PUSH RBX MOV EAX, $80000001 CPUID POP RBX MOV EAX,EDX {$ENDIF} end; function HasInstructionSet(const InstructionSet: TCPUInstructionSet): Boolean; // Must be implemented for each target CPU on which specific functions rely begin Result := False; if not CPUID_Available then Exit; // no CPUID available if CPU_Signature shr 8 and $0F < 5 then Exit; // not a Pentium class case InstructionSet of ci3DNow, ci3DNowExt: {$IFNDEF FPC} if not CPU_ExtensionsAvailable or (CPU_ExtFeatures and CPUISChecks[InstructionSet] = 0) then {$ENDIF} Exit; ciEMMX: begin // check for SSE, necessary for Intel CPUs because they don't implement the // extended info if (CPU_Features and CPUISChecks[ciSSE] = 0) and (not CPU_ExtensionsAvailable or (CPU_ExtFeatures and CPUISChecks[ciEMMX] = 0)) then Exit; end; else if CPU_Features and CPUISChecks[InstructionSet] = 0 then Exit; // return -> instruction set not supported end; Result := True; end; {$ELSE} function HasInstructionSet(const InstructionSet: TCPUInstructionSet): Boolean; begin Result := False; end; {$ENDIF} procedure InitCPUFeaturesData; var I: TCPUInstructionSet; begin if CPUFeaturesInitialized then Exit; CPUFeaturesData := []; for I := Low(TCPUInstructionSet) to High(TCPUInstructionSet) do if HasInstructionSet(I) then CPUFeaturesData := CPUFeaturesData + [I]; CPUFeaturesInitialized := True; end; function CPUFeatures: TCPUFeatures; begin if not CPUFeaturesInitialized then InitCPUFeaturesData; Result := CPUFeaturesData; end; initialization InitCPUFeaturesData; GlobalPerfTimer := TPerfTimer.Create; finalization GlobalPerfTimer.Free; end. |
Added src/graphics32/GR32_Text_LCL_Win.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 | unit GR32_Text_LCL_Win; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Vectorial Polygon Rasterizer for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * * Portions created by the Initial Developer are Copyright (C) 2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Windows, Types, GR32, GR32_Paths; procedure TextToPath(Font: HFONT; Path: TCustomPath; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal); overload; function MeasureTextDC(DC: HDC; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; overload; function MeasureText(Font: HFONT; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; type TTextHinting = (thNone, thNoHorz, thHinting); procedure SetHinting(Value: TTextHinting); function GetHinting: TTextHinting; const DT_LEFT = 0; //See also Window's DrawText() flags ... DT_CENTER = 1; //http://msdn.microsoft.com/en-us/library/ms901121.aspx DT_RIGHT = 2; DT_WORDBREAK = $10; DT_VCENTER = 4; DT_BOTTOM = 8; DT_SINGLELINE = $20; DT_JUSTIFY = 3; //Graphics32 additions ... DT_HORZ_ALIGN_MASK = 3; implementation uses GR32_LowLevel; var UseHinting: Boolean; HorzStretch: Integer; // stretching factor when calling GetGlyphOutline() HorzStretch_Inv: single; VertFlip_mat2: tmat2; const GGO_UNHINTED = $0100; GGODefaultFlags: array [Boolean] of Integer = (GGO_NATIVE or GGO_UNHINTED, GGO_NATIVE); TT_PRIM_CSPLINE = 3; MaxSingle = 3.4e+38; function PointFXtoPointF(const Point: tagPointFX): TFloatPoint; begin Result.X := Point.X.Value + Point.X.Fract * FixedToFloat; Result.Y := Point.Y.Value + Point.Y.Fract * FixedToFloat; end; function GlyphOutlineToPath(Handle: HDC; Path: TCustomPath; DstX, MaxX, DstY: Single; const Glyph: Integer; out Metrics: TGlyphMetrics): Boolean; var I, K, S: Integer; Res: DWORD; GlyphMemPtr, BufferPtr: PTTPolygonHeader; CurvePtr: PTTPolyCurve; P1, P2, P3: TFloatPoint; begin Res := GetGlyphOutlineW(Handle, Glyph, GGODefaultFlags[UseHinting], Metrics, 0, nil, VertFlip_mat2); Result := DstX + Metrics.gmCellIncX <= MaxX; if not Result or not Assigned(Path) then Exit; GetMem(GlyphMemPtr, Res); BufferPtr := GlyphMemPtr; Res := GetGlyphOutlineW(Handle, Glyph, GGODefaultFlags[UseHinting], Metrics, Res, BufferPtr, VertFlip_mat2); if (Res = GDI_ERROR) or (BufferPtr^.dwType <> TT_POLYGON_TYPE) then begin FreeMem(GlyphMemPtr); Exit; end; while Res > 0 do begin S := BufferPtr.cb - SizeOf(TTTPolygonHeader); PtrUInt(CurvePtr) := PtrUInt(BufferPtr) + SizeOf(TTTPolygonHeader); P1 := PointFXtoPointF(BufferPtr.pfxStart); Path.MoveTo(P1.X + DstX, P1.Y + DstY); while S > 0 do begin case CurvePtr.wType of TT_PRIM_LINE: for I := 0 to CurvePtr.cpfx - 1 do begin P1 := PointFXtoPointF(CurvePtr.apfx[I]); Path.LineTo(P1.X + DstX, P1.Y + DstY); end; TT_PRIM_QSPLINE: begin for I := 0 to CurvePtr.cpfx - 2 do begin P1 := PointFXtoPointF(CurvePtr.apfx[I]); if I < CurvePtr.cpfx - 2 then with PointFXtoPointF(CurvePtr.apfx[I + 1]) do begin P2.x := (P1.x + x) * 0.5; P2.y := (P1.y + y) * 0.5; end else P2 := PointFXtoPointF(CurvePtr.apfx[I + 1]); Path.ConicTo(P1.X + DstX, P1.Y + DstY, P2.X + DstX, P2.Y + DstY); end; end; TT_PRIM_CSPLINE: begin I := 0; while I < CurvePtr.cpfx - 2 do begin P1 := PointFXtoPointF(CurvePtr.apfx[I]); P2 := PointFXtoPointF(CurvePtr.apfx[I + 1]); P3 := PointFXtoPointF(CurvePtr.apfx[I + 2]); Path.CurveTo(P1.X + DstX, P1.Y + DstY, P2.X + DstX, P2.Y + DstY, P3.X + DstX, P3.Y + DstY); Inc(I, 2); end; end; end; K := (CurvePtr.cpfx - 1) * SizeOf(TPointFX) + SizeOf(TTPolyCurve); Dec(S, K); Inc(PtrInt(CurvePtr), K); end; Path.ClosePath; Dec(Res, BufferPtr.cb); Inc(PtrInt(BufferPtr), BufferPtr.cb); end; FreeMem(GlyphMemPtr); end; procedure InternalTextToPath(DC: HDC; Path: TCustomPath; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal); const CHAR_CR = 10; CHAR_NL = 13; CHAR_SP = 32; var GlyphMetrics: TGlyphMetrics; TextMetric: TTextMetric; I, J, TextLen, SpcCount, SpcX, LineStart: Integer; CharValue: Integer; CharOffsets: TArrayOfInteger; X, Y, XMax, YMax, MaxRight: Single; S: WideString; UseTempPath: Boolean; TmpPath: TFlattenedPath; {$IFDEF USEKERNING} LastCharValue: Integer; KerningPairs: PKerningPairArray; KerningPairCount: Integer; {$ENDIF} procedure AlignTextCenter(CurrentI: Integer); var M, N, PathStart, PathEnd: Integer; Delta: TFloat; begin Delta := Round((ARect.Right * HorzStretch - X - 1) * 0.5); PathStart := CharOffsets[LineStart]; PathEnd := CharOffsets[CurrentI]; for M := PathStart to PathEnd - 1 do for N := 0 to High(TmpPath.Path[M]) do TmpPath.Path[M][N].X := TmpPath.Path[M][N].X + Delta; end; procedure AlignTextRight(CurrentI: Integer); var M, N, PathStart, PathEnd: Integer; Delta: TFloat; begin Delta := Round(ARect.Right * HorzStretch - X - 1); PathStart := CharOffsets[LineStart]; PathEnd := CharOffsets[CurrentI]; for M := PathStart to PathEnd - 1 do for N := 0 to High(TmpPath.Path[M]) do TmpPath.Path[M][N].X := TmpPath.Path[M][N].X + Delta; end; procedure AlignTextJustify(CurrentI: Integer); var L, M, N, PathStart, PathEnd: Integer; SpcDelta, SpcDeltaInc: TFloat; begin if (SpcCount < 1) or (Ord(Text[CurrentI]) = CHAR_CR) then Exit; SpcDelta := (ARect.Right * HorzStretch - X - 1) / SpcCount; SpcDeltaInc := SpcDelta; L := LineStart; //Trim leading spaces ... while (L < CurrentI) and (Ord(Text[L]) = CHAR_SP) do Inc(L); //Now find first space char in line ... while (L < CurrentI) and (Ord(Text[L]) <> CHAR_SP) do Inc(L); PathStart := CharOffsets[L - 1]; repeat M := L + 1; while (M < CurrentI) and (Ord(Text[M]) <> CHAR_SP) do Inc(M); PathEnd := CharOffsets[M]; L := M; for M := PathStart to PathEnd - 1 do for N := 0 to High(TmpPath.Path[M]) do TmpPath.Path[M][N].X := TmpPath.Path[M][N].X + SpcDeltaInc; SpcDeltaInc := SpcDeltaInc + SpcDelta; PathStart := PathEnd; until L >= CurrentI; end; procedure NewLine(CurrentI: Integer); begin if (Flags and DT_SINGLELINE <> 0) then Exit; if assigned(TmpPath) then case (Flags and DT_HORZ_ALIGN_MASK) of DT_CENTER : AlignTextCenter(CurrentI); DT_RIGHT : AlignTextRight(CurrentI); DT_JUSTIFY: AlignTextJustify(CurrentI); end; X := ARect.Left * HorzStretch; Y := Y + TextMetric.tmHeight; LineStart := CurrentI; SpcCount := 0; end; function MeasureTextX(const S: WideString): Integer; var I: Integer; begin Result := 0; for I := 1 to Length(S) do begin CharValue := Ord(S[I]); GetGlyphOutlineW(DC, CharValue, GGODefaultFlags[UseHinting], GlyphMetrics, 0, nil, VertFlip_mat2); Inc(Result, GlyphMetrics.gmCellIncX); end; end; function NeedsNewLine(X: Single): boolean; begin Result := X > ARect.Right * HorzStretch; end; procedure AddSpace; begin Inc(SpcCount); X := X + SpcX; end; begin {$IFDEF USEKERNING} KerningPairs := nil; KerningPairCount := GetKerningPairs(DC, 0, nil); if GetLastError <> 0 then RaiseLastOSError; if KerningPairCount > 0 then begin GetMem(KerningPairs, KerningPairCount * SizeOf(TKerningPair)); GetKerningPairs(DC, KerningPairCount, PKerningPair(KerningPairs)); end; LastCharValue := 0; {$ENDIF} SpcCount := 0; LineStart := 0; UseTempPath := False; if Assigned(Path) then if (Path is TFlattenedPath) then begin TmpPath := TFlattenedPath(Path); TmpPath.Clear; TmpPath.BeginPath; end else begin UseTempPath := True; TmpPath := TFlattenedPath.Create end else TmpPath := nil; GetTextMetrics(DC, TextMetric); TextLen := Length(Text); X := ARect.Left * HorzStretch; Y := ARect.Top + TextMetric.tmAscent; XMax := X; if not Assigned(Path) or (ARect.Right = ARect.Left) then MaxRight := MaxSingle //either measuring text or unbounded text else MaxRight := ARect.Right * HorzStretch; SetLength(CharOffsets, TextLen +1); CharOffsets[0] := 0; GetGlyphOutlineW(DC, CHAR_SP, GGODefaultFlags[UseHinting], GlyphMetrics, 0, nil, VertFlip_mat2); SpcX := GlyphMetrics.gmCellIncX; if (Flags and DT_SINGLELINE <> 0) then begin //ignore justify when forcing singleline ... if (Flags and DT_JUSTIFY = DT_JUSTIFY) then Flags := Flags and not DT_JUSTIFY; //ignore wordbreak when forcing singleline ... if (Flags and DT_WORDBREAK = DT_WORDBREAK) then Flags := Flags and not DT_WORDBREAK; MaxRight := MaxSingle; end; for I := 1 to TextLen do begin CharValue := Ord(Text[I]); if CharValue <= 32 then begin if (Flags and DT_SINGLELINE = DT_SINGLELINE) then CharValue := CHAR_SP; if Assigned(TmpPath) then CharOffsets[I] := Length(TmpPath.Path); case CharValue of CHAR_CR: NewLine(I); CHAR_NL: ; CHAR_SP: begin if Flags and DT_WORDBREAK = DT_WORDBREAK then begin J := I + 1; while (J <= TextLen) and ([Ord(Text[J])] * [CHAR_CR, CHAR_NL, CHAR_SP] = []) do Inc(J); S := Copy(Text, I, J - I); if NeedsNewLine(X + MeasureTextX(S)) then NewLine(I) else AddSpace; end else begin if NeedsNewLine(X + SpcX) then NewLine(I) else AddSpace; end; end; end; end else begin if GlyphOutlineToPath(DC, TmpPath, X, MaxRight, Y, CharValue, GlyphMetrics) then begin if Assigned(TmpPath) then CharOffsets[I] := Length(TmpPath.Path); end else begin if Ord(Text[I -1]) = CHAR_SP then begin //this only happens without DT_WORDBREAK X := X - SpcX; Dec(SpcCount); end; //the current glyph doesn't fit so a word must be split since //it fills more than a whole line ... NewLine(I - 1); if not GlyphOutlineToPath(DC, TmpPath, X, MaxRight, Y, CharValue, GlyphMetrics) then Break; if Assigned(TmpPath) then CharOffsets[I] := Length(TmpPath.Path); end; X := X + GlyphMetrics.gmCellIncX; {$IFDEF USEKERNING} for J := 0 to KerningPairCount - 1 do begin if (KerningPairs^[J].wFirst = LastCharValue) and (KerningPairs^[J].wSecond = CharValue) then X := X + KerningPairs^[J].iKernAmount; end; LastCharValue := CharValue; {$ENDIF} if X > XMax then XMax := X; end; end; if [(Flags and DT_HORZ_ALIGN_MASK)] * [DT_CENTER, DT_RIGHT] <> [] then NewLine(TextLen); YMax := Y + TextMetric.tmHeight - TextMetric.tmAscent; //reverse HorzStretch (if any) ... if (HorzStretch <> 1) and assigned(TmpPath) then for I := 0 to High(TmpPath.Path) do for J := 0 to High(TmpPath.Path[I]) do TmpPath.Path[I][J].X := TmpPath.Path[I][J].X * HorzStretch_Inv; XMax := XMax * HorzStretch_Inv; X := ARect.Right - XMax; Y := ARect.Bottom - YMax; if Flags and (DT_VCENTER or DT_BOTTOM) <> 0 then begin if Flags and DT_VCENTER <> 0 then Y := Y * 0.5; if assigned(TmpPath) then for I := 0 to High(TmpPath.Path) do for J := 0 to High(TmpPath.Path[I]) do TmpPath.Path[I][J].Y := TmpPath.Path[I][J].Y + Y; end; {$IFDEF USEKERNING} if Assigned(KerningPairs) then FreeMem(KerningPairs); {$ENDIF} if UseTempPath then begin Path.Assign(TmpPath); TmpPath.Free; end else if Assigned(Path) then Path.EndPath; end; procedure TextToPath(Font: HFONT; Path: TCustomPath; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal); overload; var DC: HDC; SavedFont: HFONT; begin DC := GetDC(0); try SavedFont := SelectObject(DC, Font); InternalTextToPath(DC, Path, ARect, Text, Flags); SelectObject(DC, SavedFont); finally ReleaseDC(0, DC); end; end; function MeasureTextDC(DC: HDC; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; begin Result := ARect; InternalTextToPath(DC, nil, Result, Text, Flags); Result.Left := Round(Result.Left); Result.Top := Round(Result.Top); Result.Right := Round(Result.Right); Result.Bottom := Round(Result.Bottom); end; function MeasureText(Font: HFONT; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; var DC: HDC; SavedFont: HFONT; begin DC := GetDC(0); try SavedFont := SelectObject(DC, Font); Result := MeasureTextDC(DC, ARect, Text, Flags); SelectObject(DC, SavedFont); finally ReleaseDC(0, DC); end; end; procedure SetHinting(Value: TTextHinting); begin UseHinting := Value <> thNone; if (Value = thNoHorz) then HorzStretch := 16 else HorzStretch := 1; HorzStretch_Inv := 1 / HorzStretch; FillChar(VertFlip_mat2, SizeOf(VertFlip_mat2), 0); VertFlip_mat2.eM11.value := HorzStretch; VertFlip_mat2.eM22.value := -1; //reversed Y axis end; function GetHinting: TTextHinting; begin if HorzStretch <> 1 then Result := thNoHorz else if UseHinting then Result := thHinting else Result := thNone; end; procedure InitHinting; begin {$IFDEF NOHORIZONTALHINTING} SetHinting(thNoHorz); {$ELSE} {$IFDEF NOHINTING} SetHinting(thNone); {$ELSE} SetHinting(thHinting); {$ENDIF}; {$ENDIF} end; initialization InitHinting; end. |
Added src/graphics32/GR32_Text_VCL.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 | unit GR32_Text_VCL; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Vectorial Polygon Rasterizer for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * * Portions created by the Initial Developer are Copyright (C) 2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses Windows, Types, GR32, GR32_Paths; procedure TextToPath(Font: HFONT; Path: TCustomPath; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal = 0); function TextToPolyPolygon(Font: HFONT; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal = 0): TArrayOfArrayOfFloatPoint; function MeasureTextDC(DC: HDC; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal = 0): TFloatRect; overload; function MeasureText(Font: HFONT; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal = 0): TFloatRect; type TTextHinting = (thNone, thNoHorz, thHinting); TKerningPairArray = array [0..0] of TKerningPair; PKerningPairArray = ^TKerningPairArray; procedure SetHinting(Value: TTextHinting); function GetHinting: TTextHinting; const DT_LEFT = 0; //See also Window's DrawText() flags ... DT_CENTER = 1; //http://msdn.microsoft.com/en-us/library/ms901121.aspx DT_RIGHT = 2; DT_VCENTER = 4; DT_BOTTOM = 8; DT_WORDBREAK = $10; DT_SINGLELINE = $20; DT_JUSTIFY = 3; //Graphics32 additions ... DT_HORZ_ALIGN_MASK = 3; implementation uses {$IFDEF USESTACKALLOC} GR32_LowLevel, {$ENDIF} SysUtils; var UseHinting: Boolean; HorzStretch: Integer; // stretching factor when calling GetGlyphOutline() HorzStretch_Inv: single; VertFlip_mat2: tmat2; const GGO_UNHINTED = $0100; GGODefaultFlags: array [Boolean] of Integer = (GGO_NATIVE or GGO_UNHINTED, GGO_NATIVE); TT_PRIM_CSPLINE = 3; MaxSingle = 3.4e+38; // import GetKerningPairs from gdi32 library function GetKerningPairs(DC: HDC; Count: DWORD; P: PKerningPair): DWORD; stdcall; external gdi32 name 'GetKerningPairs'; function PointFXtoPointF(const Point: tagPointFX): TFloatPoint; {$IFDEF UseInlining} inline; {$ENDIF} begin Result.X := Point.X.Value + Point.X.Fract * FixedToFloat; Result.Y := Point.Y.Value + Point.Y.Fract * FixedToFloat; end; {$IFDEF USESTACKALLOC} {$W+} {$ENDIF} function GlyphOutlineToPath(Handle: HDC; Path: TCustomPath; DstX, MaxX, DstY: Single; const Glyph: Integer; out Metrics: TGlyphMetrics): Boolean; var I, K, S: Integer; Res: DWORD; GlyphMemPtr, BufferPtr: PTTPolygonHeader; CurvePtr: PTTPolyCurve; P1, P2, P3: TFloatPoint; begin Res := GetGlyphOutlineW(Handle, Glyph, GGODefaultFlags[UseHinting], Metrics, 0, nil, VertFlip_mat2); Result := DstX + Metrics.gmCellIncX <= MaxX; if not Result or not Assigned(Path) then Exit; {$IFDEF USESTACKALLOC} GlyphMemPtr := StackAlloc(Res); {$ELSE} GetMem(GlyphMemPtr, Res); {$ENDIF} BufferPtr := GlyphMemPtr; Res := GetGlyphOutlineW(Handle, Glyph, GGODefaultFlags[UseHinting], Metrics, Res, BufferPtr, VertFlip_mat2); if (Res = GDI_ERROR) or (BufferPtr^.dwType <> TT_POLYGON_TYPE) then begin {$IFDEF USESTACKALLOC} StackFree(GlyphMemPtr); {$ELSE} FreeMem(GlyphMemPtr); {$ENDIF} Exit; end; while Res > 0 do begin S := BufferPtr.cb - SizeOf(TTTPolygonHeader); {$IFDEF HAS_NATIVEINT} NativeInt(CurvePtr) := NativeInt(BufferPtr) + SizeOf(TTTPolygonHeader); {$ELSE} Integer(CurvePtr) := Integer(BufferPtr) + SizeOf(TTTPolygonHeader); {$ENDIF} P1 := PointFXtoPointF(BufferPtr.pfxStart); Path.MoveTo(P1.X + DstX, P1.Y + DstY); while S > 0 do begin case CurvePtr.wType of TT_PRIM_LINE: for I := 0 to CurvePtr.cpfx - 1 do begin P1 := PointFXtoPointF(CurvePtr.apfx[I]); Path.LineTo(P1.X + DstX, P1.Y + DstY); end; TT_PRIM_QSPLINE: begin for I := 0 to CurvePtr.cpfx - 2 do begin P1 := PointFXtoPointF(CurvePtr.apfx[I]); if I < CurvePtr.cpfx - 2 then with PointFXtoPointF(CurvePtr.apfx[I + 1]) do begin P2.x := (P1.x + x) * 0.5; P2.y := (P1.y + y) * 0.5; end else P2 := PointFXtoPointF(CurvePtr.apfx[I + 1]); Path.ConicTo(P1.X + DstX, P1.Y + DstY, P2.X + DstX, P2.Y + DstY); end; end; TT_PRIM_CSPLINE: begin I := 0; while I < CurvePtr.cpfx - 2 do begin P1 := PointFXtoPointF(CurvePtr.apfx[I]); P2 := PointFXtoPointF(CurvePtr.apfx[I + 1]); P3 := PointFXtoPointF(CurvePtr.apfx[I + 2]); Path.CurveTo(P1.X + DstX, P1.Y + DstY, P2.X + DstX, P2.Y + DstY, P3.X + DstX, P3.Y + DstY); Inc(I, 2); end; end; end; K := (CurvePtr.cpfx - 1) * SizeOf(TPointFX) + SizeOf(TTPolyCurve); Dec(S, K); {$IFDEF HAS_NATIVEINT} Inc(NativeInt(CurvePtr), K); {$ELSE} Inc(Integer(CurvePtr), K); {$ENDIF} end; Path.ClosePath; Dec(Res, BufferPtr.cb); {$IFDEF HAS_NATIVEINT} Inc(NativeInt(BufferPtr), BufferPtr.cb); {$ELSE} Inc(integer(BufferPtr), BufferPtr.cb); {$ENDIF} end; {$IFDEF USESTACKALLOC} StackFree(GlyphMemPtr); {$ELSE} FreeMem(GlyphMemPtr); {$ENDIF} end; {$IFDEF USESTACKALLOC} {$W-} {$ENDIF} procedure InternalTextToPath(DC: HDC; Path: TCustomPath; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal = 0); const CHAR_CR = 10; CHAR_NL = 13; CHAR_SP = 32; var GlyphMetrics: TGlyphMetrics; TextMetric: TTextMetric; I, J, TextLen, SpcCount, SpcX, LineStart: Integer; CharValue: Integer; CharOffsets: TArrayOfInteger; X, Y, XMax, YMax, MaxRight: Single; S: WideString; UseTempPath: Boolean; TmpPath: TFlattenedPath; {$IFDEF USEKERNING} NextCharValue: Integer; KerningPairs: PKerningPairArray; KerningPairCount: Integer; {$ENDIF} procedure AlignTextCenter(CurrentI: Integer); var M, N, PathStart, PathEnd: Integer; Delta: TFloat; begin Delta := Round((ARect.Right * HorzStretch - X - 1) * 0.5); PathStart := CharOffsets[LineStart]; PathEnd := CharOffsets[CurrentI]; for M := PathStart to PathEnd - 1 do for N := 0 to High(TmpPath.Path[M]) do TmpPath.Path[M, N].X := TmpPath.Path[M, N].X + Delta; end; procedure AlignTextRight(CurrentI: Integer); var M, N, PathStart, PathEnd: Integer; Delta: TFloat; begin Delta := Round(ARect.Right * HorzStretch - X - 1); PathStart := CharOffsets[LineStart]; PathEnd := CharOffsets[CurrentI]; for M := PathStart to PathEnd - 1 do for N := 0 to High(TmpPath.Path[M]) do TmpPath.Path[M, N].X := TmpPath.Path[M, N].X + Delta; end; procedure AlignTextJustify(CurrentI: Integer); var L, M, N, PathStart, PathEnd: Integer; SpcDelta, SpcDeltaInc: TFloat; begin if (SpcCount < 1) or (Ord(Text[CurrentI]) = CHAR_CR) then Exit; SpcDelta := (ARect.Right * HorzStretch - X - 1) / SpcCount; SpcDeltaInc := SpcDelta; L := LineStart; // Trim leading spaces ... while (L < CurrentI) and (Ord(Text[L]) = CHAR_SP) do Inc(L); // Now find first space char in line ... while (L < CurrentI) and (Ord(Text[L]) <> CHAR_SP) do Inc(L); PathStart := CharOffsets[L - 1]; repeat M := L + 1; while (M < CurrentI) and (Ord(Text[M]) <> CHAR_SP) do Inc(M); PathEnd := CharOffsets[M]; L := M; for M := PathStart to PathEnd - 1 do for N := 0 to High(TmpPath.Path[M]) do TmpPath.Path[M, N].X := TmpPath.Path[M, N].X + SpcDeltaInc; SpcDeltaInc := SpcDeltaInc + SpcDelta; PathStart := PathEnd; until L >= CurrentI; end; procedure NewLine(CurrentI: Integer); begin if (Flags and DT_SINGLELINE <> 0) then Exit; if Assigned(TmpPath) then case (Flags and DT_HORZ_ALIGN_MASK) of DT_CENTER : AlignTextCenter(CurrentI); DT_RIGHT : AlignTextRight(CurrentI); DT_JUSTIFY: AlignTextJustify(CurrentI); end; X := ARect.Left * HorzStretch; Y := Y + TextMetric.tmHeight; LineStart := CurrentI; SpcCount := 0; end; function MeasureTextX(const S: WideString): Integer; var I: Integer; begin Result := 0; for I := 1 to Length(S) do begin CharValue := Ord(S[I]); GetGlyphOutlineW(DC, CharValue, GGODefaultFlags[UseHinting], GlyphMetrics, 0, nil, VertFlip_mat2); Inc(Result, GlyphMetrics.gmCellIncX); end; end; function NeedsNewLine(X: Single): Boolean; begin Result := (ARect.Right > ARect.Left) and (X > ARect.Right * HorzStretch); end; procedure AddSpace; begin Inc(SpcCount); X := X + SpcX; end; begin {$IFDEF USEKERNING} KerningPairs := nil; KerningPairCount := GetKerningPairs(DC, 0, nil); if GetLastError <> 0 then RaiseLastOSError; if KerningPairCount > 0 then begin GetMem(KerningPairs, KerningPairCount * SizeOf(TKerningPair)); GetKerningPairs(DC, KerningPairCount, PKerningPair(KerningPairs)); end; {$ENDIF} SpcCount := 0; LineStart := 0; UseTempPath := False; if Assigned(Path) then if (Path is TFlattenedPath) then begin TmpPath := TFlattenedPath(Path); TmpPath.Clear; TmpPath.BeginPath; end else begin UseTempPath := True; TmpPath := TFlattenedPath.Create end else TmpPath := nil; GetTextMetrics(DC, TextMetric); TextLen := Length(Text); X := ARect.Left * HorzStretch; Y := ARect.Top + TextMetric.tmAscent; XMax := X; if not Assigned(Path) or (ARect.Right = ARect.Left) then MaxRight := MaxSingle //either measuring text or unbounded text else MaxRight := ARect.Right * HorzStretch; SetLength(CharOffsets, TextLen + 1); CharOffsets[0] := 0; GetGlyphOutlineW(DC, CHAR_SP, GGODefaultFlags[UseHinting], GlyphMetrics, 0, nil, VertFlip_mat2); SpcX := GlyphMetrics.gmCellIncX; if (Flags and DT_SINGLELINE <> 0) or (ARect.Left = ARect.Right) then begin // ignore justify when forcing singleline ... if (Flags and DT_JUSTIFY = DT_JUSTIFY) then Flags := Flags and not DT_JUSTIFY; // ignore wordbreak when forcing singleline ... if (Flags and DT_WORDBREAK = DT_WORDBREAK) then Flags := Flags and not DT_WORDBREAK; MaxRight := MaxSingle; end; for I := 1 to TextLen do begin CharValue := Ord(Text[I]); if CharValue <= 32 then begin if (Flags and DT_SINGLELINE = DT_SINGLELINE) then CharValue := CHAR_SP; if Assigned(TmpPath) then CharOffsets[I] := Length(TmpPath.Path); case CharValue of CHAR_CR: NewLine(I); CHAR_NL: ; CHAR_SP: begin if Flags and DT_WORDBREAK = DT_WORDBREAK then begin J := I + 1; while (J <= TextLen) and ([Ord(Text[J])] * [CHAR_CR, CHAR_NL, CHAR_SP] = []) do Inc(J); S := Copy(Text, I, J - I); if NeedsNewLine(X + MeasureTextX(S)) then NewLine(I) else AddSpace; end else begin if NeedsNewLine(X + SpcX) then NewLine(I) else AddSpace; end; end; end; end else begin if GlyphOutlineToPath(DC, TmpPath, X, MaxRight, Y, CharValue, GlyphMetrics) then begin if Assigned(TmpPath) then CharOffsets[I] := Length(TmpPath.Path); end else begin if Ord(Text[I - 1]) = CHAR_SP then begin // this only happens without DT_WORDBREAK X := X - SpcX; Dec(SpcCount); end; // the current glyph doesn't fit so a word must be split since // it fills more than a whole line ... NewLine(I - 1); if not GlyphOutlineToPath(DC, TmpPath, X, MaxRight, Y, CharValue, GlyphMetrics) then Break; if Assigned(TmpPath) then CharOffsets[I] := Length(TmpPath.Path); end; X := X + GlyphMetrics.gmCellIncX; {$IFDEF USEKERNING} if i < TextLen then NextCharValue := Ord(Text[i + 1]); for J := 0 to KerningPairCount - 1 do begin if (KerningPairs^[J].wFirst = CharValue) and (KerningPairs^[J].wSecond = NextCharValue) then begin X := X + KerningPairs^[J].iKernAmount; break; end; end; {$ENDIF} if X > XMax then XMax := X; end; end; if [(Flags and DT_HORZ_ALIGN_MASK)] * [DT_CENTER, DT_RIGHT] <> [] then NewLine(TextLen); YMax := Y + TextMetric.tmHeight - TextMetric.tmAscent; // reverse HorzStretch (if any) ... if (HorzStretch <> 1) and assigned(TmpPath) then for I := 0 to High(TmpPath.Path) do for J := 0 to High(TmpPath.Path[I]) do TmpPath.Path[I, J].X := TmpPath.Path[I, J].X * HorzStretch_Inv; XMax := XMax * HorzStretch_Inv; X := ARect.Right - XMax; Y := ARect.Bottom - YMax; if Flags and (DT_VCENTER or DT_BOTTOM) <> 0 then begin if Flags and DT_VCENTER <> 0 then Y := Y * 0.5; if Assigned(TmpPath) then for I := 0 to High(TmpPath.Path) do for J := 0 to High(TmpPath.Path[I]) do TmpPath.Path[I, J].Y := TmpPath.Path[I, J].Y + Y; end; {$IFDEF USEKERNING} if Assigned(KerningPairs) then FreeMem(KerningPairs); {$ENDIF} if UseTempPath then begin Path.Assign(TmpPath); TmpPath.Free; end else if Assigned(Path) then Path.EndPath; end; procedure TextToPath(Font: HFONT; Path: TCustomPath; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal = 0); var DC: HDC; SavedFont: HFONT; begin DC := GetDC(0); try SavedFont := SelectObject(DC, Font); InternalTextToPath(DC, Path, ARect, Text, Flags); SelectObject(DC, SavedFont); finally ReleaseDC(0, DC); end; end; function TextToPolyPolygon(Font: HFONT; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal = 0): TArrayOfArrayOfFloatPoint; var Path: TFlattenedPath; begin Path := TFlattenedPath.Create; try TextToPath(Font, Path, ARect, Text, Flags); Result := Path.Path; finally Path.Free; end; end; function MeasureTextDC(DC: HDC; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; begin Result := ARect; InternalTextToPath(DC, nil, Result, Text, Flags); Result.Left := Round(Result.Left); Result.Top := Round(Result.Top); Result.Right := Round(Result.Right); Result.Bottom := Round(Result.Bottom); end; function MeasureText(Font: HFONT; const ARect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; var DC: HDC; SavedFont: HFONT; begin DC := GetDC(0); try SavedFont := SelectObject(DC, Font); Result := MeasureTextDC(DC, ARect, Text, Flags); SelectObject(DC, SavedFont); finally ReleaseDC(0, DC); end; end; procedure SetHinting(Value: TTextHinting); begin UseHinting := Value <> thNone; if (Value = thNoHorz) then HorzStretch := 16 else HorzStretch := 1; HorzStretch_Inv := 1 / HorzStretch; FillChar(VertFlip_mat2, SizeOf(VertFlip_mat2), 0); VertFlip_mat2.eM11.value := HorzStretch; VertFlip_mat2.eM22.value := -1; //reversed Y axis end; function GetHinting: TTextHinting; begin if HorzStretch <> 1 then Result := thNoHorz else if UseHinting then Result := thHinting else Result := thNone; end; procedure InitHinting; begin {$IFDEF NOHORIZONTALHINTING} SetHinting(thNoHorz); {$ELSE} {$IFDEF NOHINTING} SetHinting(thNone); {$ELSE} SetHinting(thHinting); {$ENDIF} {$ENDIF} end; initialization InitHinting; end. |
Added src/graphics32/GR32_Transforms.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 | unit GR32_Transforms; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Andre Beckedorf <Andre@metaException.de> * Mattias Andersson <Mattias@Centaurix.com> * J. Tulach <tulach@position.cz> * Michael Hansen <dyster_tid@hotmail.com> * Peter Larson * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, {$ELSE} Windows, {$ENDIF} SysUtils, Classes, Types, GR32, GR32_VectorMaps, GR32_Rasterizers; type ETransformError = class(Exception); ETransformNotImplemented = class(Exception); type TFloatMatrix = array [0..2, 0..2] of TFloat; // 3x3 TFloat precision TFixedMatrix = array [0..2, 0..2] of TFixed; // 3x3 fixed precision const IdentityMatrix: TFloatMatrix = ( (1, 0, 0), (0, 1, 0), (0, 0, 1)); type TVector3f = array [0..2] of TFloat; TVector3i = array [0..2] of Integer; // Matrix conversion routines function FixedMatrix(const FloatMatrix: TFloatMatrix): TFixedMatrix; overload; function FloatMatrix(const FixedMatrix: TFixedMatrix): TFloatMatrix; overload; procedure Adjoint(var M: TFloatMatrix); function Determinant(const M: TFloatMatrix): TFloat; procedure Scale(var M: TFloatMatrix; Factor: TFloat); procedure Invert(var M: TFloatMatrix); function Mult(const M1, M2: TFloatMatrix): TFloatMatrix; function VectorTransform(const M: TFloatMatrix; const V: TVector3f): TVector3f; type TTransformation = class(TNotifiablePersistent) private FSrcRect: TFloatRect; procedure SetSrcRect(const Value: TFloatRect); protected TransformValid: Boolean; procedure PrepareTransform; virtual; procedure ReverseTransformInt(DstX, DstY: Integer; out SrcX, SrcY: Integer); virtual; procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); virtual; procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); virtual; procedure TransformInt(SrcX, SrcY: Integer; out DstX, DstY: Integer); virtual; procedure TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); virtual; procedure TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); virtual; public constructor Create; virtual; procedure Changed; override; function HasTransformedBounds: Boolean; virtual; function GetTransformedBounds: TFloatRect; overload; function GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; overload; virtual; function ReverseTransform(const P: TPoint): TPoint; overload; virtual; function ReverseTransform(const P: TFixedPoint): TFixedPoint; overload; virtual; function ReverseTransform(const P: TFloatPoint): TFloatPoint; overload; virtual; function Transform(const P: TPoint): TPoint; overload; virtual; function Transform(const P: TFixedPoint): TFixedPoint; overload; virtual; function Transform(const P: TFloatPoint): TFloatPoint; overload; virtual; property SrcRect: TFloatRect read FSrcRect write SetSrcRect; end; TTransformationClass = class of TTransformation; TNestedTransformation = class(TTransformation) private FItems: TList; FOwner: TPersistent; function GetCount: Integer; function GetItem(Index: Integer): TTransformation; procedure SetItem(Index: Integer; const Value: TTransformation); protected procedure PrepareTransform; override; procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); override; procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; procedure TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); override; procedure TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); override; public constructor Create; override; destructor Destroy; override; function Add(ItemClass: TTransformationClass): TTransformation; procedure Clear; procedure Delete(Index: Integer); function Insert(Index: Integer; ItemClass: TTransformationClass): TTransformation; property Owner: TPersistent read FOwner; property Count: Integer read GetCount; property Items[Index: Integer]: TTransformation read GetItem write SetItem; default; end; T3x3Transformation = class(TTransformation) protected FMatrix, FInverseMatrix: TFloatMatrix; FFixedMatrix, FInverseFixedMatrix: TFixedMatrix; procedure PrepareTransform; override; procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); override; procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; procedure TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); override; procedure TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); override; public property Matrix: TFloatMatrix read FMatrix; end; TAffineTransformation = class(T3x3Transformation) private FStack: ^TFloatMatrix; FStackLevel: Integer; public constructor Create; override; function GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; override; procedure Push; procedure Pop; procedure Clear; overload; procedure Clear(BaseMatrix: TFloatMatrix); overload; procedure Rotate(Alpha: TFloat); overload; // degrees procedure Rotate(Cx, Cy, Alpha: TFloat); overload; // degrees procedure Skew(Fx, Fy: TFloat); procedure Scale(Sx, Sy: TFloat); overload; procedure Scale(Value: TFloat); overload; procedure Translate(Dx, Dy: TFloat); end; TProjectiveTransformation = class(T3x3Transformation) private FQuadX: array [0..3] of TFloat; FQuadY: array [0..3] of TFloat; procedure SetX(Index: Integer; const Value: TFloat); {$IFDEF UseInlining} inline; {$ENDIF} procedure SetY(Index: Integer; const Value: TFloat); {$IFDEF UseInlining} inline; {$ENDIF} function GetX(Index: Integer): TFloat; {$IFDEF UseInlining} inline; {$ENDIF} function GetY(Index: Integer): TFloat; {$IFDEF UseInlining} inline; {$ENDIF} protected procedure PrepareTransform; override; procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); override; procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; procedure TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); override; procedure TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); override; public function GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; override; property X[Index: Integer]: TFloat read GetX write SetX; property Y[index: Integer]: TFloat read GetX write SetY; published property X0: TFloat index 0 read GetX write SetX; property X1: TFloat index 1 read GetX write SetX; property X2: TFloat index 2 read GetX write SetX; property X3: TFloat index 3 read GetX write SetX; property Y0: TFloat index 0 read GetY write SetY; property Y1: TFloat index 1 read GetY write SetY; property Y2: TFloat index 2 read GetY write SetY; property Y3: TFloat index 3 read GetY write SetY; end; TTwirlTransformation = class(TTransformation) private Frx, Fry: TFloat; FTwirl: TFloat; procedure SetTwirl(const Value: TFloat); protected procedure PrepareTransform; override; procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; public constructor Create; override; function GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; override; published property Twirl: TFloat read FTwirl write SetTwirl; end; TBloatTransformation = class(TTransformation) private FBloatPower: TFloat; FBP: TFloat; FPiW, FPiH: TFloat; procedure SetBloatPower(const Value: TFloat); protected procedure PrepareTransform; override; procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; procedure TransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; public constructor Create; override; published property BloatPower: TFloat read FBloatPower write SetBloatPower; end; TDisturbanceTransformation = class(TTransformation) private FDisturbance: TFloat; procedure SetDisturbance(const Value: TFloat); protected procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; public function GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; override; published property Disturbance: TFloat read FDisturbance write SetDisturbance; end; TFishEyeTransformation = class(TTransformation) private Frx, Fry: TFloat; Faw, Fsr: TFloat; Sx, Sy: TFloat; FMinR: TFloat; protected procedure PrepareTransform; override; procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; end; TPolarTransformation = class(TTransformation) private FDstRect: TFloatRect; FPhase: TFloat; Sx, Sy, Cx, Cy, Dx, Dy, Rt, Rt2, Rr, Rcx, Rcy: TFloat; procedure SetDstRect(const Value: TFloatRect); procedure SetPhase(const Value: TFloat); protected procedure PrepareTransform; override; procedure TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); override; procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; public property DstRect: TFloatRect read FDstRect write SetDstRect; property Phase: TFloat read FPhase write SetPhase; end; TPathTransformation = class(TTransformation) private FTopLength: TFloat; FBottomLength: TFloat; FBottomCurve: TArrayOfFloatPoint; FTopCurve: TArrayOfFloatPoint; FTopHypot, FBottomHypot: array of record Dist, RecDist: TFloat end; procedure SetBottomCurve(const Value: TArrayOfFloatPoint); procedure SetTopCurve(const Value: TArrayOfFloatPoint); protected rdx, rdy: TFloat; procedure PrepareTransform; override; procedure TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); override; public destructor Destroy; override; property TopCurve: TArrayOfFloatPoint read FTopCurve write SetTopCurve; property BottomCurve: TArrayOfFloatPoint read FBottomCurve write SetBottomCurve; end; TRemapTransformation = class(TTransformation) private FVectorMap : TVectorMap; FScalingFixed: TFixedVector; FScalingFloat: TFloatVector; FCombinedScalingFixed: TFixedVector; FCombinedScalingFloat: TFloatVector; FSrcTranslationFixed: TFixedVector; FSrcScaleFixed: TFixedVector; FDstTranslationFixed: TFixedVector; FDstScaleFixed: TFixedVector; FSrcTranslationFloat: TFloatVector; FSrcScaleFloat: TFloatVector; FDstTranslationFloat: TFloatVector; FDstScaleFloat: TFloatVector; FOffsetFixed : TFixedVector; FOffsetInt : TPoint; FMappingRect: TFloatRect; FOffset: TFloatVector; procedure SetMappingRect(Rect: TFloatRect); procedure SetOffset(const Value: TFloatVector); protected procedure PrepareTransform; override; procedure ReverseTransformInt(DstX, DstY: Integer; out SrcX, SrcY: Integer); override; procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); override; public constructor Create; override; destructor Destroy; override; function HasTransformedBounds: Boolean; override; function GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; override; procedure Scale(Sx, Sy: TFloat); property MappingRect: TFloatRect read FMappingRect write SetMappingRect; property Offset: TFloatVector read FOffset write SetOffset; property VectorMap: TVectorMap read FVectorMap write FVectorMap; end; function TransformPoints(Points: TArrayOfArrayOfFixedPoint; Transformation: TTransformation): TArrayOfArrayOfFixedPoint; procedure Transform(Dst, Src: TCustomBitmap32; Transformation: TTransformation); overload; procedure Transform(Dst, Src: TCustomBitmap32; Transformation: TTransformation; const DstClip: TRect); overload; procedure Transform(Dst, Src: TCustomBitmap32; Transformation: TTransformation; Rasterizer: TRasterizer); overload; procedure Transform(Dst, Src: TCustomBitmap32; Transformation: TTransformation; Rasterizer: TRasterizer; const DstClip: TRect); overload; procedure RasterizeTransformation(Vectormap: TVectormap; Transformation: TTransformation; DstRect: TRect; CombineMode: TVectorCombineMode = vcmAdd; CombineCallback: TVectorCombineEvent = nil); procedure SetBorderTransparent(ABitmap: TCustomBitmap32; ARect: TRect); { FullEdge controls how the bitmap is resampled } var FullEdge: Boolean = True; resourcestring RCStrReverseTransformationNotImplemented = 'Reverse transformation is not implemented in %s.'; RCStrForwardTransformationNotImplemented = 'Forward transformation is not implemented in %s.'; RCStrTopBottomCurveNil = 'Top or bottom curve is nil'; implementation uses Math, GR32_Blend, GR32_LowLevel, GR32_Math, GR32_Bindings, GR32_Resamplers; resourcestring RCStrSrcRectIsEmpty = 'SrcRect is empty!'; RCStrMappingRectIsEmpty = 'MappingRect is empty!'; RStrStackEmpty = 'Stack empty'; type {provides access to proctected members of TCustomBitmap32 by typecasting} TTransformationAccess = class(TTransformation); var DET32: function(a1, a2, b1, b2: Single): Single; DET64: function(a1, a2, b1, b2: Double): Double; { A bit of linear algebra } function DET32_Pas(a1, a2, b1, b2: Single): Single; overload; begin Result := a1 * b2 - a2 * b1; end; function DET64_Pas(a1, a2, b1, b2: Double): Double; overload; begin Result := a1 * b2 - a2 * b1; end; {$IFNDEF PUREPASCAL} function DET32_ASM(a1, a2, b1, b2: Single): Single; overload; asm {$IFDEF CPU64} MULSS XMM0, XMM3 MULSS XMM1, XMM2 ADDSS XMM0, XMM1 {$ELSE} FLD A1.Single FMUL B2.Single FLD A2.Single FMUL B1.Single FSUBP {$ENDIF} end; function DET64_ASM(a1, a2, b1, b2: Double): Double; overload; asm {$IFDEF CPU64} MULSD XMM0, XMM3 MULSD XMM1, XMM2 ADDSD XMM0, XMM1 {$ELSE} FLD A1.Double FMUL B2.Double FLD A2.Double FMUL B1.Double FSUBP {$ENDIF} end; {$ENDIF} { implementation of detereminant for TFloat precision } function _DET(a1, a2, b1, b2: TFloat): TFloat; overload; {$IFDEF UseInlining} inline; {$ENDIF} begin Result := a1 * b2 - a2 * b1; end; function _DET(a1, a2, a3, b1, b2, b3, c1, c2, c3: TFloat): TFloat; overload; {$IFDEF UseInlining} inline; {$ENDIF} begin Result := a1 * (b2 * c3 - b3 * c2) - b1 * (a2 * c3 - a3 * c2) + c1 * (a2 * b3 - a3 * b2); end; procedure Adjoint(var M: TFloatMatrix); var Tmp: TFloatMatrix; begin Tmp := M; M[0,0] := _DET(Tmp[1,1], Tmp[1,2], Tmp[2,1], Tmp[2,2]); M[0,1] := -_DET(Tmp[0,1], Tmp[0,2], Tmp[2,1], Tmp[2,2]); M[0,2] := _DET(Tmp[0,1], Tmp[0,2], Tmp[1,1], Tmp[1,2]); M[1,0] := -_DET(Tmp[1,0], Tmp[1,2], Tmp[2,0], Tmp[2,2]); M[1,1] := _DET(Tmp[0,0], Tmp[0,2], Tmp[2,0], Tmp[2,2]); M[1,2] := -_DET(Tmp[0,0], Tmp[0,2], Tmp[1,0], Tmp[1,2]); M[2,0] := _DET(Tmp[1,0], Tmp[1,1], Tmp[2,0], Tmp[2,1]); M[2,1] := -_DET(Tmp[0,0], Tmp[0,1], Tmp[2,0], Tmp[2,1]); M[2,2] := _DET(Tmp[0,0], Tmp[0,1], Tmp[1,0], Tmp[1,1]); end; function Determinant(const M: TFloatMatrix): TFloat; begin Result := _DET(M[0,0], M[1,0], M[2,0], M[0,1], M[1,1], M[2,1], M[0,2], M[1,2], M[2,2]); end; procedure Scale(var M: TFloatMatrix; Factor: TFloat); var i, j: Integer; begin for i := 0 to 2 do for j := 0 to 2 do M[i,j] := M[i,j] * Factor; end; procedure Invert(var M: TFloatMatrix); var Det: TFloat; begin Det := Determinant(M); if Abs(Det) < 1E-5 then M := IdentityMatrix else begin Adjoint(M); Scale(M, 1 / Det); end; end; function Mult(const M1, M2: TFloatMatrix): TFloatMatrix; var i, j: Integer; begin for i := 0 to 2 do for j := 0 to 2 do Result[i, j] := M1[0, j] * M2[i, 0] + M1[1, j] * M2[i, 1] + M1[2, j] * M2[i, 2]; end; function VectorTransform(const M: TFloatMatrix; const V: TVector3f): TVector3f; begin Result[0] := M[0,0] * V[0] + M[1,0] * V[1] + M[2,0] * V[2]; Result[1] := M[0,1] * V[0] + M[1,1] * V[1] + M[2,1] * V[2]; Result[2] := M[0,2] * V[0] + M[1,2] * V[1] + M[2,2] * V[2]; end; { Transformation functions } function TransformPoints(Points: TArrayOfArrayOfFixedPoint; Transformation: TTransformation): TArrayOfArrayOfFixedPoint; var I, J: Integer; begin if Points = nil then Result := nil else begin SetLength(Result, Length(Points)); Transformation.PrepareTransform; for I := 0 to High(Result) do begin SetLength(Result[I], Length(Points[I])); if Length(Result[I]) > 0 then for J := 0 to High(Result[I]) do Transformation.TransformFixed(Points[I][J].X, Points[I][J].Y, Result[I][J].X, Result[I][J].Y); end; end; end; procedure Transform(Dst, Src: TCustomBitmap32; Transformation: TTransformation); var Rasterizer: TRasterizer; begin Rasterizer := DefaultRasterizerClass.Create; try Transform(Dst, Src, Transformation, Rasterizer); finally Rasterizer.Free; end; end; procedure Transform(Dst, Src: TCustomBitmap32; Transformation: TTransformation; const DstClip: TRect); var Rasterizer: TRasterizer; begin Rasterizer := DefaultRasterizerClass.Create; try Transform(Dst, Src, Transformation, Rasterizer, DstClip); finally Rasterizer.Free; end; end; procedure Transform(Dst, Src: TCustomBitmap32; Transformation: TTransformation; Rasterizer: TRasterizer); begin Transform(Dst, Src, Transformation, Rasterizer, Dst.BoundsRect); end; procedure Transform(Dst, Src: TCustomBitmap32; Transformation: TTransformation; Rasterizer: TRasterizer; const DstClip: TRect); var DstRect: TRect; Transformer: TTransformer; begin GR32.IntersectRect(DstRect, DstClip, Dst.ClipRect); if (DstRect.Right < DstRect.Left) or (DstRect.Bottom < DstRect.Top) then Exit; if not Dst.MeasuringMode then begin Transformer := TTransformer.Create(Src.Resampler, Transformation); try Rasterizer.Sampler := Transformer; Rasterizer.Rasterize(Dst, DstRect, Src); finally EMMS; Transformer.Free; end; end; Dst.Changed(DstRect); end; procedure SetBorderTransparent(ABitmap: TCustomBitmap32; ARect: TRect); var I: Integer; begin GR32.IntersectRect(ARect, ARect, ABitmap.BoundsRect); with ARect, ABitmap do if (Right > Left) and (Bottom > Top) and (Left < ClipRect.Right) and (Top < ClipRect.Bottom) and (Right > ClipRect.Left) and (Bottom > ClipRect.Top) then begin Dec(Right); Dec(Bottom); for I := Left to Right do begin ABitmap[I, Top] := ABitmap[I, Top] and $00FFFFFF; ABitmap[I, Bottom] := ABitmap[I, Bottom] and $00FFFFFF; end; for I := Top to Bottom do begin ABitmap[Left, I] := ABitmap[Left, I] and $00FFFFFF; ABitmap[Right, I] := ABitmap[Right, I] and $00FFFFFF; end; Changed; end; end; { TTransformation } function TTransformation.GetTransformedBounds: TFloatRect; begin Result := GetTransformedBounds(FSrcRect); end; procedure TTransformation.Changed; begin TransformValid := False; inherited; end; constructor TTransformation.Create; begin // virtual constructor to be overriden in derived classes end; function TTransformation.GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; begin Result := ASrcRect; end; function TTransformation.HasTransformedBounds: Boolean; begin Result := True; end; procedure TTransformation.PrepareTransform; begin // Dummy end; function TTransformation.ReverseTransform(const P: TFloatPoint): TFloatPoint; begin if not TransformValid then PrepareTransform; ReverseTransformFloat(P.X, P.Y, Result.X, Result.Y); end; function TTransformation.ReverseTransform(const P: TFixedPoint): TFixedPoint; begin if not TransformValid then PrepareTransform; ReverseTransformFixed(P.X, P.Y, Result.X, Result.Y); end; function TTransformation.ReverseTransform(const P: TPoint): TPoint; begin if not TransformValid then PrepareTransform; ReverseTransformInt(P.X, P.Y, Result.X, Result.Y); end; procedure TTransformation.ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); var X, Y: TFloat; begin ReverseTransformFloat(DstX * FixedToFloat, DstY * FixedToFloat, X, Y); SrcX := Fixed(X); SrcY := Fixed(Y); end; procedure TTransformation.ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); begin // ReverseTransformFloat is the top precisionlevel, all descendants must override at least this level! raise ETransformNotImplemented.CreateFmt(RCStrReverseTransformationNotImplemented, [Self.Classname]); end; procedure TTransformation.ReverseTransformInt(DstX, DstY: Integer; out SrcX, SrcY: Integer); var X, Y: TFixed; begin ReverseTransformFixed(DstX shl 16, DstY shl 16, X, Y); SrcX := FixedRound(X); SrcY := FixedRound(Y); end; procedure TTransformation.SetSrcRect(const Value: TFloatRect); begin FSrcRect := Value; Changed; end; function TTransformation.Transform(const P: TFloatPoint): TFloatPoint; begin if not TransformValid then PrepareTransform; TransformFloat(P.X, P.Y, Result.X, Result.Y); end; function TTransformation.Transform(const P: TFixedPoint): TFixedPoint; begin if not TransformValid then PrepareTransform; TransformFixed(P.X, P.Y, Result.X, Result.Y); end; function TTransformation.Transform(const P: TPoint): TPoint; begin if not TransformValid then PrepareTransform; TransformInt(P.X, P.Y, Result.X, Result.Y); end; procedure TTransformation.TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); var X, Y: TFloat; begin TransformFloat(SrcX * FixedToFloat, SrcY * FixedToFloat, X, Y); DstX := Fixed(X); DstY := Fixed(Y); end; procedure TTransformation.TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); begin // TransformFloat is the top precisionlevel, all descendants must override at least this level! raise ETransformNotImplemented.CreateFmt(RCStrForwardTransformationNotImplemented, [Self.Classname]); end; procedure TTransformation.TransformInt(SrcX, SrcY: Integer; out DstX, DstY: Integer); var X, Y: TFixed; begin TransformFixed(SrcX shl 16, SrcY shl 16, X, Y); DstX := FixedRound(X); DstY := FixedRound(Y); end; { TNestedTransformation } constructor TNestedTransformation.Create; begin FItems := TList.Create; end; destructor TNestedTransformation.Destroy; begin if Assigned(FItems) then Clear; FItems.Free; inherited; end; function TNestedTransformation.Add( ItemClass: TTransformationClass): TTransformation; begin Result := ItemClass.Create; FItems.Add(Result); end; procedure TNestedTransformation.Clear; begin BeginUpdate; try while FItems.Count > 0 do Delete(FItems.Count - 1); finally EndUpdate; end; end; procedure TNestedTransformation.Delete(Index: Integer); begin TTransformation(FItems[Index]).Free; FItems.Delete(Index); end; function TNestedTransformation.GetCount: Integer; begin Result := FItems.Count; end; function TNestedTransformation.GetItem(Index: Integer): TTransformation; begin Result := FItems[Index]; end; function TNestedTransformation.Insert(Index: Integer; ItemClass: TTransformationClass): TTransformation; begin BeginUpdate; try Result := Add(ItemClass); finally EndUpdate; end; end; procedure TNestedTransformation.PrepareTransform; var Index: Integer; begin for Index := 0 to Count - 1 do TTransformation(FItems[Index]).PrepareTransform; end; procedure TNestedTransformation.ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); var Index: Integer; begin for Index := 0 to Count - 1 do begin TTransformation(FItems[Index]).ReverseTransformFixed(DstX, DstY, SrcX, SrcY); DstX := SrcX; DstY := SrcY; end; end; procedure TNestedTransformation.ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); var Index: Integer; begin for Index := 0 to Count - 1 do begin TTransformation(FItems[Index]).ReverseTransformFloat(DstX, DstY, SrcX, SrcY); DstX := SrcX; DstY := SrcY; end; end; procedure TNestedTransformation.SetItem(Index: Integer; const Value: TTransformation); begin TCollectionItem(FItems[Index]).Assign(Value); end; procedure TNestedTransformation.TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); var Index: Integer; begin for Index := 0 to Count - 1 do begin TTransformation(FItems[Index]).TransformFixed(SrcX, SrcY, DstX, DstY); SrcX := DstX; SrcY := DstY; end; end; procedure TNestedTransformation.TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); var Index: Integer; begin for Index := 0 to Count - 1 do begin TTransformation(FItems[Index]).TransformFloat(SrcX, SrcY, DstX, DstY); SrcX := DstX; SrcY := DstY; end; end; { T3x3Transformation } procedure T3x3Transformation.PrepareTransform; begin FInverseMatrix := Matrix; Invert(FInverseMatrix); // calculate a fixed point (65536) factors FInverseFixedMatrix := FixedMatrix(FInverseMatrix); FFixedMatrix := FixedMatrix(Matrix); TransformValid := True; end; procedure T3x3Transformation.ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); begin SrcX := FixedMul(DstX, FInverseFixedMatrix[0, 0]) + FixedMul(DstY, FInverseFixedMatrix[1, 0]) + FInverseFixedMatrix[2, 0]; SrcY := FixedMul(DstX, FInverseFixedMatrix[0, 1]) + FixedMul(DstY, FInverseFixedMatrix[1, 1]) + FInverseFixedMatrix[2, 1]; end; procedure T3x3Transformation.ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); begin SrcX := DstX * FInverseMatrix[0, 0] + DstY * FInverseMatrix[1, 0] + FInverseMatrix[2, 0]; SrcY := DstX * FInverseMatrix[0, 1] + DstY * FInverseMatrix[1, 1] + FInverseMatrix[2, 1]; end; procedure T3x3Transformation.TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); begin DstX := FixedMul(SrcX, FFixedMatrix[0, 0]) + FixedMul(SrcY, FFixedMatrix[1, 0]) + FFixedMatrix[2, 0]; DstY := FixedMul(SrcX, FFixedMatrix[0, 1]) + FixedMul(SrcY, FFixedMatrix[1, 1]) + FFixedMatrix[2, 1]; end; procedure T3x3Transformation.TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); begin DstX := SrcX * Matrix[0, 0] + SrcY * Matrix[1, 0] + Matrix[2, 0]; DstY := SrcX * Matrix[0, 1] + SrcY * Matrix[1, 1] + Matrix[2, 1]; end; { TAffineTransformation } constructor TAffineTransformation.Create; begin FStackLevel := 0; FStack := nil; Clear; end; procedure TAffineTransformation.Clear; begin FMatrix := IdentityMatrix; Changed; end; procedure TAffineTransformation.Clear(BaseMatrix: TFloatMatrix); begin FMatrix := BaseMatrix; Changed; end; function TAffineTransformation.GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; var V1, V2, V3, V4: TVector3f; begin V1[0] := ASrcRect.Left; V1[1] := ASrcRect.Top; V1[2] := 1; V2[0] := ASrcRect.Right; V2[1] := V1[1]; V2[2] := 1; V3[0] := V1[0]; V3[1] := ASrcRect.Bottom; V3[2] := 1; V4[0] := V2[0]; V4[1] := V3[1]; V4[2] := 1; V1 := VectorTransform(Matrix, V1); V2 := VectorTransform(Matrix, V2); V3 := VectorTransform(Matrix, V3); V4 := VectorTransform(Matrix, V4); Result.Left := Min(Min(V1[0], V2[0]), Min(V3[0], V4[0])); Result.Right := Max(Max(V1[0], V2[0]), Max(V3[0], V4[0])); Result.Top := Min(Min(V1[1], V2[1]), Min(V3[1], V4[1])); Result.Bottom := Max(Max(V1[1], V2[1]), Max(V3[1], V4[1])); end; procedure TAffineTransformation.Push; begin Inc(FStackLevel); ReallocMem(FStack, FStackLevel * SizeOf(TFloatMatrix)); Move(FMatrix, FStack^[FStackLevel - 1], SizeOf(TFloatMatrix)); end; procedure TAffineTransformation.Pop; begin if FStackLevel <= 0 then raise Exception.Create(RStrStackEmpty); Move(FStack^[FStackLevel - 1], FMatrix, SizeOf(TFloatMatrix)); Dec(FStackLevel); Changed; end; procedure TAffineTransformation.Rotate(Alpha: TFloat); var S, C: TFloat; M: TFloatMatrix; begin Alpha := DegToRad(Alpha); GR32_Math.SinCos(Alpha, S, C); M := IdentityMatrix; M[0, 0] := C; M[1, 0] := S; M[0, 1] := -S; M[1, 1] := C; FMatrix := Mult(M, Matrix); Changed; end; procedure TAffineTransformation.Rotate(Cx, Cy, Alpha: TFloat); var S, C: TFloat; M: TFloatMatrix; begin if (Cx <> 0) or (Cy <> 0) then Translate(-Cx, -Cy); Alpha := DegToRad(Alpha); GR32_Math.SinCos(Alpha, S, C); M := IdentityMatrix; M[0, 0] := C; M[1, 0] := S; M[0, 1] := -S; M[1, 1] := C; FMatrix := Mult(M, Matrix); if (Cx <> 0) or (Cy <> 0) then Translate(Cx, Cy); Changed; end; procedure TAffineTransformation.Scale(Sx, Sy: TFloat); var M: TFloatMatrix; begin M := IdentityMatrix; M[0, 0] := Sx; M[1, 1] := Sy; FMatrix := Mult(M, Matrix); Changed; end; procedure TAffineTransformation.Scale(Value: TFloat); var M: TFloatMatrix; begin M := IdentityMatrix; M[0, 0] := Value; M[1, 1] := Value; FMatrix := Mult(M, Matrix); Changed; end; procedure TAffineTransformation.Skew(Fx, Fy: TFloat); var M: TFloatMatrix; begin M := IdentityMatrix; M[1, 0] := Fx; M[0, 1] := Fy; FMatrix := Mult(M, Matrix); Changed; end; procedure TAffineTransformation.Translate(Dx, Dy: TFloat); var M: TFloatMatrix; begin M := IdentityMatrix; M[2, 0] := Dx; M[2, 1] := Dy; FMatrix := Mult(M, Matrix); Changed; end; { TProjectiveTransformation } function TProjectiveTransformation.GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; begin Result.Left := Min(Min(FQuadX[0], FQuadX[1]), Min(FQuadX[2], FQuadX[3])); Result.Right := Max(Max(FQuadX[0], FQuadX[1]), Max(FQuadX[2], FQuadX[3])); Result.Top := Min(Min(FQuadY[0], FQuadY[1]), Min(FQuadY[2], FQuadY[3])); Result.Bottom := Max(Max(FQuadY[0], FQuadY[1]), Max(FQuadY[2], FQuadY[3])); end; function TProjectiveTransformation.GetX(Index: Integer): TFloat; begin Result := FQuadX[Index]; end; function TProjectiveTransformation.GetY(Index: Integer): TFloat; begin Result := FQuadY[Index]; end; procedure TProjectiveTransformation.PrepareTransform; var dx1, dx2, px, dy1, dy2, py: TFloat; g, h, k: TFloat; R: TFloatMatrix; begin px := FQuadX[0] - FQuadX[1] + FQuadX[2] - FQuadX[3]; py := FQuadY[0] - FQuadY[1] + FQuadY[2] - FQuadY[3]; if (px = 0) and (py = 0) then begin // affine mapping FMatrix[0, 0] := FQuadX[1] - FQuadX[0]; FMatrix[1, 0] := FQuadX[2] - FQuadX[1]; FMatrix[2, 0] := FQuadX[0]; FMatrix[0, 1] := FQuadY[1] - FQuadY[0]; FMatrix[1, 1] := FQuadY[2] - FQuadY[1]; FMatrix[2, 1] := FQuadY[0]; FMatrix[0, 2] := 0; FMatrix[1, 2] := 0; FMatrix[2, 2] := 1; end else begin // projective mapping dx1 := FQuadX[1] - FQuadX[2]; dx2 := FQuadX[3] - FQuadX[2]; dy1 := FQuadY[1] - FQuadY[2]; dy2 := FQuadY[3] - FQuadY[2]; k := dx1 * dy2 - dx2 * dy1; if k <> 0 then begin k := 1 / k; g := (px * dy2 - py * dx2) * k; h := (dx1 * py - dy1 * px) * k; FMatrix[0, 0] := FQuadX[1] - FQuadX[0] + g * FQuadX[1]; FMatrix[1, 0] := FQuadX[3] - FQuadX[0] + h * FQuadX[3]; FMatrix[2, 0] := FQuadX[0]; FMatrix[0, 1] := FQuadY[1] - FQuadY[0] + g * FQuadY[1]; FMatrix[1, 1] := FQuadY[3] - FQuadY[0] + h * FQuadY[3]; FMatrix[2, 1] := FQuadY[0]; FMatrix[0, 2] := g; FMatrix[1, 2] := h; FMatrix[2, 2] := 1; end else begin FillChar(FMatrix, SizeOf(FMatrix), 0); end; end; // denormalize texture space (u, v) R := IdentityMatrix; R[0, 0] := 1 / (SrcRect.Right - SrcRect.Left); R[1, 1] := 1 / (SrcRect.Bottom - SrcRect.Top); FMatrix := Mult(FMatrix, R); R := IdentityMatrix; R[2, 0] := -SrcRect.Left; R[2, 1] := -SrcRect.Top; FMatrix := Mult(FMatrix, R); inherited; end; procedure TProjectiveTransformation.SetX(Index: Integer; const Value: TFloat); begin FQuadX[Index] := Value; Changed; end; procedure TProjectiveTransformation.SetY(Index: Integer; const Value: TFloat); begin FQuadY[Index] := Value; Changed; end; procedure TProjectiveTransformation.ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); var Z: TFixed; Zf: TFloat; begin Z := FixedMul(FInverseFixedMatrix[0, 2], DstX) + FixedMul(FInverseFixedMatrix[1, 2], DstY) + FInverseFixedMatrix[2, 2]; if Z = 0 then Exit; {$IFDEF UseInlining} SrcX := FixedMul(DstX, FInverseFixedMatrix[0, 0]) + FixedMul(DstY, FInverseFixedMatrix[1, 0]) + FInverseFixedMatrix[2, 0]; SrcY := FixedMul(DstX, FInverseFixedMatrix[0,1]) + FixedMul(DstY, FInverseFixedMatrix[1, 1]) + FInverseFixedMatrix[2, 1]; {$ELSE} inherited; {$ENDIF} if Z <> FixedOne then begin EMMS; Zf := FixedOne / Z; SrcX := Round(SrcX * Zf); SrcY := Round(SrcY * Zf); end; end; procedure TProjectiveTransformation.ReverseTransformFloat( DstX, DstY: TFloat; out SrcX, SrcY: TFloat); var Z: TFloat; begin EMMS; Z := FInverseMatrix[0, 2] * DstX + FInverseMatrix[1, 2] * DstY + FInverseMatrix[2, 2]; if Z = 0 then Exit; {$IFDEF UseInlining} SrcX := DstX * FInverseMatrix[0, 0] + DstY * FInverseMatrix[1, 0] + FInverseMatrix[2, 0]; SrcY := DstX * FInverseMatrix[0, 1] + DstY * FInverseMatrix[1, 1] + FInverseMatrix[2, 1]; {$ELSE} inherited; {$ENDIF} if Z <> 1 then begin Z := 1 / Z; SrcX := SrcX * Z; SrcY := SrcY * Z; end; end; procedure TProjectiveTransformation.TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); var Z: TFixed; Zf: TFloat; begin Z := FixedMul(FFixedMatrix[0, 2], SrcX) + FixedMul(FFixedMatrix[1, 2], SrcY) + FFixedMatrix[2, 2]; if Z = 0 then Exit; {$IFDEF UseInlining} DstX := FixedMul(SrcX, FFixedMatrix[0, 0]) + FixedMul(SrcY, FFixedMatrix[1, 0]) + FFixedMatrix[2, 0]; DstY := FixedMul(SrcX, FFixedMatrix[0, 1]) + FixedMul(SrcY, FFixedMatrix[1, 1]) + FFixedMatrix[2, 1]; {$ELSE} inherited; {$ENDIF} if Z <> FixedOne then begin EMMS; Zf := FixedOne / Z; DstX := Round(DstX * Zf); DstY := Round(DstY * Zf); end; end; procedure TProjectiveTransformation.TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); var Z: TFloat; begin EMMS; Z := FMatrix[0, 2] * SrcX + FMatrix[1, 2] * SrcY + FMatrix[2, 2]; if Z = 0 then Exit; {$IFDEF UseInlining} DstX := SrcX * Matrix[0, 0] + SrcY * Matrix[1, 0] + Matrix[2, 0]; DstY := SrcX * Matrix[0, 1] + SrcY * Matrix[1, 1] + Matrix[2, 1]; {$ELSE} inherited; {$ENDIF} if Z <> 1 then begin Z := 1 / Z; DstX := DstX * Z; DstY := DstY * Z; end; end; { TTwirlTransformation } constructor TTwirlTransformation.Create; begin FTwirl := 0.03; end; function TTwirlTransformation.GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; var Cx, Cy, R: TFloat; const CPiHalf: TFloat = 0.5 * Pi; begin Cx := (ASrcRect.Left + ASrcRect.Right) * 0.5; Cy := (ASrcRect.Top + ASrcRect.Bottom) * 0.5; R := Max(Cx - ASrcRect.Left, Cy - ASrcRect.Top); Result.Left := Cx - R * CPiHalf; Result.Right := Cx + R * CPiHalf; Result.Top := Cy - R * CPiHalf; Result.Bottom := Cy + R * CPiHalf; end; procedure TTwirlTransformation.PrepareTransform; begin with FSrcRect do begin Frx := (Right - Left) * 0.5; Fry := (Bottom - Top) * 0.5; end; TransformValid := True; end; procedure TTwirlTransformation.ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); var xf, yf, r, t: Single; begin xf := DstX - Frx; yf := DstY - Fry; r := GR32_Math.Hypot(xf, yf); t := ArcTan2(yf, xf) + r * FTwirl; GR32_Math.SinCos(t, yf, xf); SrcX := Frx + r * xf; SrcY := Fry + r * yf; end; procedure TTwirlTransformation.SetTwirl(const Value: TFloat); begin FTwirl := Value; Changed; end; { TBloatTransformation } constructor TBloatTransformation.Create; begin FBloatPower := 0.3; end; procedure TBloatTransformation.PrepareTransform; begin FPiW := (Pi / (FSrcRect.Right - FSrcRect.Left)); FPiH := (Pi / (FSrcRect.Bottom - FSrcRect.Top)); FBP := FBloatPower * Max(FSrcRect.Right - FSrcRect.Left, FSrcRect.Bottom - FSrcRect.Top); TransformValid := True; end; procedure TBloatTransformation.ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); var SinY, CosY, SinX, CosX, t: Single; begin GR32_Math.SinCos(FPiH * DstY, SinY, CosY); GR32_Math.SinCos(FPiW * DstX, SinX, CosX); t := FBP * SinY * SinX; SrcX := DstX + t * CosX; SrcY := DstY + t * CosY; end; procedure TBloatTransformation.TransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); var SinY, CosY, SinX, CosX, t: Single; begin GR32_Math.SinCos(-FPiH * DstY, SinY, CosY); GR32_Math.SinCos(-FPiW * DstX, SinX, CosX); t := FBP * SinY * SinX; SrcX := DstX + t * CosX; SrcY := DstY + t * CosY; end; procedure TBloatTransformation.SetBloatPower(const Value: TFloat); begin FBloatPower := Value; Changed; end; { TFishEyeTransformation } procedure TFishEyeTransformation.PrepareTransform; begin with FSrcRect do begin Frx := (Right - Left) * 0.5; Fry := (Bottom - Top) * 0.5; if Frx <= Fry then begin FMinR := Frx; Sx := 1; Sy:= Frx / Fry; end else begin FMinR := Fry; Sx:= Fry / Frx; Sy := 1; end; Fsr := 1 / FMinR; Faw := ArcSin(Constrain(FMinR * Fsr, -1, 1)); if Faw <> 0 then Faw := 1 / Faw; Faw := Faw * FMinR end; TransformValid := True; end; procedure TFishEyeTransformation.ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); var d, Xrx, Yry: TFloat; begin Yry := (DstY - Fry) * sy; Xrx := (DstX - Frx) * sx; d := GR32_Math.Hypot(Xrx, Yry); if (d < FMinR) and (d > 0) then begin d := ArcSin(d * Fsr) * Faw / d; SrcX := Frx + Xrx * d; SrcY := Fry + Yry * d; end else begin SrcX := DstX; SrcY := DstY; end; end; { TPolarTransformation } procedure TPolarTransformation.PrepareTransform; begin Sx := SrcRect.Right - SrcRect.Left; Sy := SrcRect.Bottom - SrcRect.Top; Cx := (DstRect.Left + DstRect.Right) * 0.5; Cy := (DstRect.Top + DstRect.Bottom) * 0.5; Dx := DstRect.Right - Cx; Dy := DstRect.Bottom - Cy; Rt := (1 / (PI * 2)) * Sx; Rt2 := Sx; if Rt2 <> 0 then Rt2 := 1 / Sx else Rt2 := 0.00000001; Rt2 := Rt2 * 2 * Pi; Rr := Sy; if Rr <> 0 then Rr := 1 / Rr else Rr := 0.00000001; Rcx := Cx; if Rcx <> 0 then Rcx := 1 / Rcx else Rcx := 0.00000001; Rcy := Cy; if Rcy <> 0 then Rcy := 1 / Rcy else Rcy := 0.00000001; TransformValid := True; end; procedure TPolarTransformation.SetDstRect(const Value: TFloatRect); begin FDstRect := Value; Changed; end; procedure TPolarTransformation.TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); var R, Theta, S, C: TFloat; begin Theta := (SrcX - SrcRect.Left) * Rt2 + Phase; R := (SrcY - SrcRect.Bottom) * Rr; GR32_Math.SinCos(Theta, S, C); DstX := Dx * R * C + Cx; DstY := Dy * R * S + Cy; end; procedure TPolarTransformation.ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); const PI2 = 2 * PI; var Dcx, Dcy, Theta: TFloat; begin Dcx := (DstX - Cx) * Rcx; Dcy := (DstY - Cy) * Rcy; Theta := ArcTan2(Dcy, Dcx) + Pi - Phase; if Theta < 0 then Theta := Theta + PI2; SrcX := SrcRect.Left + Theta * Rt; SrcY := SrcRect.Bottom - GR32_Math.Hypot(Dcx, Dcy) * Sy; end; procedure TPolarTransformation.SetPhase(const Value: TFloat); begin FPhase := Value; Changed; end; { TPathTransformation } destructor TPathTransformation.Destroy; begin FTopHypot := nil; FBottomHypot := nil; inherited; end; procedure TPathTransformation.PrepareTransform; var I: Integer; L, DDist: TFloat; begin if not (Assigned(FTopCurve) and Assigned(FBottomCurve)) then raise ETransformError.Create(RCStrTopBottomCurveNil); SetLength(FTopHypot, Length(FTopCurve)); SetLength(FBottomHypot, Length(FBottomCurve)); L := 0; for I := 0 to High(FTopCurve) - 1 do begin FTopHypot[I].Dist := L; with FTopCurve[I + 1] do L := L + GR32_Math.Hypot(FTopCurve[I].X - X, FTopCurve[I].Y - Y); end; FTopLength := L; for I := 1 to High(FTopCurve) do with FTopHypot[I] do begin DDist := Dist - FTopHypot[I - 1].Dist; if DDist <> 0 then RecDist := 1 / DDist else if I > 1 then RecDist := FTopHypot[I - 1].RecDist else RecDist := 0; end; L := 0; for I := 0 to High(FBottomCurve) - 1 do begin FBottomHypot[I].Dist := L; with FBottomCurve[I + 1] do L := L + GR32_Math.Hypot(FBottomCurve[I].X - X, FBottomCurve[I].Y - Y); end; FBottomLength := L; for I := 1 to High(FBottomCurve) do with FBottomHypot[I] do begin DDist := Dist - FBottomHypot[I - 1].Dist; if DDist <> 0 then RecDist := 1 / DDist else if I > 1 then RecDist := FBottomHypot[I - 1].RecDist else RecDist := 0; end; rdx := 1 / (SrcRect.Right - SrcRect.Left); rdy := 1 / (SrcRect.Bottom - SrcRect.Top); TransformValid := True; end; procedure TPathTransformation.SetBottomCurve(const Value: TArrayOfFloatPoint); begin FBottomCurve := Value; Changed; end; procedure TPathTransformation.SetTopCurve(const Value: TArrayOfFloatPoint); begin FTopCurve := Value; Changed; end; procedure TPathTransformation.TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); var I, H: Integer; X, Y, fx, dx, dy, r, Tx, Ty, Bx, By: TFloat; begin X := (SrcX - SrcRect.Left) * rdx; Y := (SrcY - SrcRect.Top) * rdy; fx := X * FTopLength; I := 1; H := High(FTopHypot); while (FTopHypot[I].Dist < fx) and (I < H) do Inc(I); with FTopHypot[I] do r := (Dist - fx) * RecDist; dx := (FTopCurve[I - 1].X - FTopCurve[I].X); dy := (FTopCurve[I - 1].Y - FTopCurve[I].Y); Tx := FTopCurve[I].X + r * dx; Ty := FTopCurve[I].Y + r * dy; fx := X * FBottomLength; I := 1; H := High(FBottomHypot); while (FBottomHypot[I].Dist < fx) and (I < H) do Inc(I); with FBottomHypot[I] do r := (Dist - fx) * RecDist; dx := (FBottomCurve[I - 1].X - FBottomCurve[I].X); dy := (FBottomCurve[I - 1].Y - FBottomCurve[I].Y); Bx := FBottomCurve[I].X + r * dx; By := FBottomCurve[I].Y + r * dy; DstX := Tx + Y * (Bx - Tx); DstY := Ty + Y * (By - Ty); end; { TDisturbanceTransformation } function TDisturbanceTransformation.GetTransformedBounds( const ASrcRect: TFloatRect): TFloatRect; begin Result := ASrcRect; InflateRect(Result, 0.5 * FDisturbance, 0.5 * FDisturbance); end; procedure TDisturbanceTransformation.ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); begin SrcX := DstX + (Random - 0.5) * FDisturbance; SrcY := DstY + (Random - 0.5) * FDisturbance; end; procedure TDisturbanceTransformation.SetDisturbance(const Value: TFloat); begin FDisturbance := Value; Changed; end; { TRemapTransformation } constructor TRemapTransformation.Create; begin inherited; FScalingFixed := FixedPoint(1, 1); FScalingFloat := FloatPoint(1, 1); FOffset := FloatPoint(0,0); FVectorMap := TVectorMap.Create; //Ensuring initial setup to avoid exceptions FVectorMap.SetSize(1, 1); end; destructor TRemapTransformation.Destroy; begin FVectorMap.Free; inherited; end; function TRemapTransformation.GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; const InfRect: TFloatRect = (Left: -Infinity; Top: -Infinity; Right: Infinity; Bottom: Infinity); begin // We can't predict the ultimate bounds without transforming each vector in // the vector map, return the absolute biggest possible transformation bounds Result := InfRect; end; function TRemapTransformation.HasTransformedBounds: Boolean; begin Result := False; end; procedure TRemapTransformation.PrepareTransform; begin if IsRectEmpty(SrcRect) then raise Exception.Create(RCStrSrcRectIsEmpty); if IsRectEmpty(FMappingRect) then raise Exception.Create(RCStrMappingRectIsEmpty); with SrcRect do begin FSrcTranslationFloat.X := Left; FSrcTranslationFloat.Y := Top; FSrcScaleFloat.X := (Right - Left) / (FVectorMap.Width - 1); FSrcScaleFloat.Y := (Bottom - Top) / (FVectorMap.Height - 1); FSrcTranslationFixed := FixedPoint(FSrcTranslationFloat); FSrcScaleFixed := FixedPoint(FSrcScaleFloat); end; with FMappingRect do begin FDstTranslationFloat.X := Left; FDstTranslationFloat.Y := Top; FDstScaleFloat.X := (FVectorMap.Width - 1) / (Right - Left); FDstScaleFloat.Y := (FVectorMap.Height - 1) / (Bottom - Top); FCombinedScalingFloat.X := FDstScaleFloat.X * FScalingFloat.X; FCombinedScalingFloat.Y := FDstScaleFloat.Y * FScalingFloat.Y; FCombinedScalingFixed := FixedPoint(FCombinedScalingFloat); FDstTranslationFixed := FixedPoint(FDstTranslationFloat); FDstScaleFixed := FixedPoint(FDstScaleFloat); end; TransformValid := True; end; procedure TRemapTransformation.ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); begin with FVectorMap.FixedVectorX[DstX - FOffsetFixed.X, DstY - FOffsetFixed.Y] do begin DstX := DstX - FDstTranslationFixed.X; DstX := FixedMul(DstX , FDstScaleFixed.X); DstX := DstX + FixedMul(X, FCombinedScalingFixed.X); DstX := FixedMul(DstX, FSrcScaleFixed.X); SrcX := DstX + FSrcTranslationFixed.X; DstY := DstY - FDstTranslationFixed.Y; DstY := FixedMul(DstY, FDstScaleFixed.Y); DstY := DstY + FixedMul(Y, FCombinedScalingFixed.Y); DstY := FixedMul(DstY, FSrcScaleFixed.Y); SrcY := DstY + FSrcTranslationFixed.Y; end; end; procedure TRemapTransformation.ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); begin with FVectorMap.FloatVectorF[DstX - FOffset.X, DstY - FOffset.Y] do begin DstX := DstX - FDstTranslationFloat.X; DstY := DstY - FDstTranslationFloat.Y; DstX := DstX * FDstScaleFloat.X; DstY := DstY * FDstScaleFloat.Y; DstX := DstX + X * FCombinedScalingFloat.X; DstY := DstY + Y * FCombinedScalingFloat.Y; DstX := DstX * FSrcScaleFloat.X; DstY := DstY * FSrcScaleFloat.Y; SrcX := DstX + FSrcTranslationFloat.X; SrcY := DstY + FSrcTranslationFloat.Y; end; end; procedure TRemapTransformation.ReverseTransformInt(DstX, DstY: Integer; out SrcX, SrcY: Integer); begin with FVectorMap.FixedVector[DstX - FOffsetInt.X, DstY - FOffsetInt.Y] do begin DstX := DstX * FixedOne - FDstTranslationFixed.X; DstY := DstY * FixedOne - FDstTranslationFixed.Y; DstX := FixedMul(DstX, FDstScaleFixed.X); DstY := FixedMul(DstY, FDstScaleFixed.Y); DstX := DstX + FixedMul(X, FCombinedScalingFixed.X); DstY := DstY + FixedMul(Y, FCombinedScalingFixed.Y); DstX := FixedMul(DstX, FSrcScaleFixed.X); DstY := FixedMul(DstY, FSrcScaleFixed.Y); SrcX := FixedRound(DstX + FSrcTranslationFixed.X); SrcY := FixedRound(DstY + FSrcTranslationFixed.Y); end; end; procedure TRemapTransformation.Scale(Sx, Sy: TFloat); begin FScalingFixed.X := Fixed(Sx); FScalingFixed.Y := Fixed(Sy); FScalingFloat.X := Sx; FScalingFloat.Y := Sy; Changed; end; procedure TRemapTransformation.SetMappingRect(Rect: TFloatRect); begin FMappingRect := Rect; Changed; end; procedure TRemapTransformation.SetOffset(const Value: TFloatVector); begin FOffset := Value; FOffsetInt := Point(Value); FOffsetFixed := FixedPoint(Value); Changed; end; procedure RasterizeTransformation(Vectormap: TVectormap; Transformation: TTransformation; DstRect: TRect; CombineMode: TVectorCombineMode = vcmAdd; CombineCallback: TVectorCombineEvent = nil); var I, J: Integer; P, Q, Progression: TFixedVector; ProgressionX, ProgressionY: TFixed; MapPtr: PFixedPointArray; begin GR32.IntersectRect(DstRect, VectorMap.BoundsRect, DstRect); if GR32.IsRectEmpty(DstRect) then Exit; if not TTransformationAccess(Transformation).TransformValid then TTransformationAccess(Transformation).PrepareTransform; case CombineMode of vcmAdd: begin with DstRect do for I := Top to Bottom - 1 do begin MapPtr := @VectorMap.Vectors[I * VectorMap.Width]; for J := Left to Right - 1 do begin P := FixedPoint(Integer(J - Left), Integer(I - Top)); Q := Transformation.ReverseTransform(P); Inc(MapPtr[J].X, Q.X - P.X); Inc(MapPtr[J].Y, Q.Y - P.Y); end; end; end; vcmReplace: begin with DstRect do for I := Top to Bottom - 1 do begin MapPtr := @VectorMap.Vectors[I * VectorMap.Width]; for J := Left to Right - 1 do begin P := FixedPoint(Integer(J - Left), Integer(I - Top)); Q := Transformation.ReverseTransform(P); MapPtr[J].X := Q.X - P.X; MapPtr[J].Y := Q.Y - P.Y; end; end; end; else // vcmCustom ProgressionX := Fixed(1 / (DstRect.Right - DstRect.Left - 1)); ProgressionY := Fixed(1 / (DstRect.Bottom - DstRect.Top - 1)); Progression.Y := 0; with DstRect do for I := Top to Bottom - 1 do begin Progression.X := 0; MapPtr := @VectorMap.Vectors[I * VectorMap.Width]; for J := Left to Right - 1 do begin P := FixedPoint(Integer(J - Left), Integer(I - Top)); Q := Transformation.ReverseTransform(P); Q.X := Q.X - P.X; Q.Y := Q.Y - P.Y; CombineCallback(Q, Progression, MapPtr[J]); Inc(Progression.X, ProgressionX); end; Inc(Progression.Y, ProgressionY); end; end; end; { Matrix conversion routines } function FixedMatrix(const FloatMatrix: TFloatMatrix): TFixedMatrix; begin Result[0,0] := Round(FloatMatrix[0,0] * FixedOne); Result[0,1] := Round(FloatMatrix[0,1] * FixedOne); Result[0,2] := Round(FloatMatrix[0,2] * FixedOne); Result[1,0] := Round(FloatMatrix[1,0] * FixedOne); Result[1,1] := Round(FloatMatrix[1,1] * FixedOne); Result[1,2] := Round(FloatMatrix[1,2] * FixedOne); Result[2,0] := Round(FloatMatrix[2,0] * FixedOne); Result[2,1] := Round(FloatMatrix[2,1] * FixedOne); Result[2,2] := Round(FloatMatrix[2,2] * FixedOne); end; function FloatMatrix(const FixedMatrix: TFixedMatrix): TFloatMatrix; begin Result[0,0] := FixedMatrix[0,0] * FixedToFloat; Result[0,1] := FixedMatrix[0,1] * FixedToFloat; Result[0,2] := FixedMatrix[0,2] * FixedToFloat; Result[1,0] := FixedMatrix[1,0] * FixedToFloat; Result[1,1] := FixedMatrix[1,1] * FixedToFloat; Result[1,2] := FixedMatrix[1,2] * FixedToFloat; Result[2,0] := FixedMatrix[2,0] * FixedToFloat; Result[2,1] := FixedMatrix[2,1] * FixedToFloat; Result[2,2] := FixedMatrix[2,2] * FixedToFloat; end; {CPU target and feature Function templates} const FID_DETERMINANT32 = 0; FID_DETERMINANT64 = 1; {Complete collection of unit templates} var Registry: TFunctionRegistry; procedure RegisterBindings; begin Registry := NewRegistry('GR32_Transforms bindings'); Registry.RegisterBinding(FID_DETERMINANT32, @@DET32); Registry.Add(FID_DETERMINANT32, @DET32_Pas, []); {$IFNDEF PUREPASCAL} Registry.Add(FID_DETERMINANT32, @DET32_ASM, []); // Registry.Add(FID_DETERMINANT32, @DET32_SSE2, [ciSSE2]); {$ENDIF} Registry.RegisterBinding(FID_DETERMINANT64, @@DET64); Registry.Add(FID_DETERMINANT64, @DET64_Pas, []); {$IFNDEF PUREPASCAL} Registry.Add(FID_DETERMINANT64, @DET64_ASM, []); // Registry.Add(FID_DETERMINANT64, @DET64_SSE2, [ciSSE2]); {$ENDIF} Registry.RebindAll; end; initialization RegisterBindings; end. |
Added src/graphics32/GR32_VPR.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 | unit GR32_VPR; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Vectorial Polygon Rasterizer for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * * Portions created by the Initial Developer are Copyright (C) 2008-2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses GR32; type PInteger = ^Integer; PSingleArray = GR32.PSingleArray; TSingleArray = GR32.TSingleArray; PValueSpan = ^TValueSpan; TValueSpan = record X1, X2: Integer; Values: PSingleArray; end; TRenderSpanEvent = procedure(const Span: TValueSpan; DstY: Integer) of object; TRenderSpanProc = procedure(Data: Pointer; const Span: TValueSpan; DstY: Integer); procedure RenderPolyPolygon(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; const RenderProc: TRenderSpanProc; Data: Pointer = nil); overload; procedure RenderPolygon(const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; const RenderProc: TRenderSpanProc; Data: Pointer = nil); overload; procedure RenderPolyPolygon(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; const RenderProc: TRenderSpanEvent); overload; procedure RenderPolygon(const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; const RenderProc: TRenderSpanEvent); overload; implementation uses Math, GR32_Math, GR32_LowLevel, GR32_VectorUtils; type TArrayOfValueSpan = array of TValueSpan; PValueSpanArray = ^TValueSpanArray; TValueSpanArray = array [0..0] of TValueSpan; PLineSegment = ^TLineSegment; TLineSegment = array [0..1] of TFloatPoint; TArrayOfLineSegment = array of TLineSegment; PLineSegmentArray = ^TLineSegmentArray; TLineSegmentArray = array [0..0] of TLineSegment; PScanLine = ^TScanLine; TScanLine = record Segments: PLineSegmentArray; Count: Integer; Y: Integer; end; TScanLines = array of TScanLine; PScanLineArray = ^TScanLineArray; TScanLineArray = array [0..0] of TScanLine; procedure IntegrateSegment(var P1, P2: TFloatPoint; Values: PSingleArray); var X1, X2, I: Integer; Dx, Dy, DyDx, Sx, Y, fracX1, fracX2: TFloat; begin X1 := Round(P1.X); X2 := Round(P2.X); if X1 = X2 then begin Values[X1] := Values[X1] + 0.5 * (P2.X - P1.X) * (P1.Y + P2.Y); end else begin fracX1 := P1.X - X1; fracX2 := P2.X - X2; Dx := P2.X - P1.X; Dy := P2.Y - P1.Y; DyDx := Dy/Dx; if X1 < X2 then begin Sx := 1 - fracX1; Y := P1.Y + Sx * DyDx; Values[X1] := Values[X1] + 0.5 * (P1.Y + Y) * Sx; for I := X1 + 1 to X2 - 1 do begin Values[I] := Values[I] + (Y + DyDx * 0.5); // N: Sx = 1 Y := Y + DyDx; end; Sx := fracX2; Values[X2] := Values[X2] + 0.5 * (Y + P2.Y) * Sx; end else // X1 > X2 begin Sx := fracX1; Y := P1.Y - Sx * DyDx; Values[X1] := Values[X1] - 0.5 * (P1.Y + Y) * Sx; for I := X1 - 1 downto X2 + 1 do begin Values[I] := Values[I] - (Y - DyDx * 0.5); // N: Sx = -1 Y := Y - DyDx; end; Sx := 1 - fracX2; Values[X2] := Values[X2] - 0.5 * (Y + P2.Y) * Sx; end; end; end; procedure ExtractSingleSpan(const ScanLine: TScanLine; out Span: TValueSpan; SpanData: PSingleArray); var I, X: Integer; P: PFloatPoint; S: PLineSegment; fracX: TFloat; Points: PFloatPointArray; N: Integer; begin N := ScanLine.Count * 2; Points := @ScanLine.Segments[0]; Span.X1 := High(Integer); Span.X2 := Low(Integer); for I := 0 to N - 1 do begin P := @Points[I]; X := Round(P.X); if X < Span.X1 then Span.X1 := X; if P.Y = 1 then begin fracX := P.X - X; if Odd(I) then begin SpanData[X] := SpanData[X] + (1 - fracX); Inc(X); SpanData[X] := SpanData[X] + fracX; end else begin SpanData[X] := SpanData[X] - (1 - fracX); Inc(X); SpanData[X] := SpanData[X] - fracX; end; end; if X > Span.X2 then Span.X2 := X; end; CumSum(@SpanData[Span.X1], Span.X2 - Span.X1 + 1); for I := 0 to ScanLine.Count - 1 do begin S := @ScanLine.Segments[I]; IntegrateSegment(S[0], S[1], SpanData); end; Span.Values := @SpanData[Span.X1]; end; (* procedure ExtractPackedSpans(const ScanLine: TScanLine; out Spans: PValueSpanArray; out Count: Integer); const SpanDelta = 16; {** N: this constant adjusts the span subdivision size } var I, J, X, J1, J2: Integer; Values: PSingleArray; SpanData: PSingleArray; P: TFloatPoint; S: PLineSegment; V, fracX: TFloat; Points: PFloatPointArray; N, SpanWidth: Integer; X1, X2: Integer; Span: PValueSpan; begin N := ScanLine.Count * 2; Points := @ScanLine.Segments[0]; X1 := ScanLine.X1; X2 := ScanLine.X2; SpanWidth := X2 - X1 + 1; FillLongWord(ScanLine.SpanData[0], SpanWidth + 1, 0); Count := (SpanWidth - 1) div SpanDelta + 1; GetMem(Spans, Count * SizeOf(TValueSpan)); for I := 0 to Count - 1 do begin Spans[I].SpanMode := smPacked; end; for I := 0 to ScanLine.Count - 1 do begin S := @ScanLine.Segments[I]; J1 := (Round(S[0].X) - X1) div SpanDelta; J2 := (Round(S[1].X) - X1) div SpanDelta; if J1 > J2 then Swap(J1, J2); for J := J1 to J2 do Spans[J].SpanMode := smUnpacked; end; SpanData := ScanLine.SpanData; Values := @SpanData[-X1]; for I := 0 to N - 1 do begin P := Points[I]; if P.Y = 1 then begin X := Round(P.X); fracX := P.X - X; if Odd(I) then begin Values[X] := Values[X] + (1 - fracX); Inc(X); Values[X] := Values[X] + fracX; end else begin Values[X] := Values[X] - (1 - fracX); Inc(X); Values[X] := Values[X] - fracX; end; end; end; Span := @Spans[0]; Span.X1 := X1; Span.Values := @SpanData[0]; for I := 1 to Count - 1 do begin if Spans[I].SpanMode <> Span.SpanMode then begin X := I * SpanDelta; Span.X2 := X1 + X - 1; Inc(Span); Span^ := Spans[I]; Span.Values := @SpanData[X]; Span.X1 := X1 + X; end else Dec(Count); end; Span.X2 := X2; V := 0; Span := @Spans[0]; if Span.SpanMode = smPacked then Span.Values[0] := V; for I := 0 to Count - 1 do begin if Span.SpanMode = smPacked then begin V := Span.Values[0]; Span.Value := V; end else begin Span.Values[0] := Span.Values[0] + V; CumSum(Span.Values, Span.X2 - Span.X1 + 2); end; Inc(Span); end; for I := 0 to ScanLine.Count - 1 do begin S := @ScanLine.Segments[I]; IntegrateSegment(S[0], S[1], Values); end; end; *) procedure AddSegment(const X1, Y1, X2, Y2: TFloat; var ScanLine: TScanLine); {$IFDEF USEINLINING} inline; {$ENDIF} var S: PLineSegment; begin if (Y1 = 0) and (Y2 = 0) then Exit; {** needed for proper clipping } with ScanLine do begin S := @Segments[Count]; Inc(Count); end; S[0].X := X1; S[0].Y := Y1; S[1].X := X2; S[1].Y := Y2; end; procedure DivideSegment(var P1, P2: TFloatPoint; const ScanLines: PScanLineArray); var Y, Y1, Y2: Integer; k, X: TFloat; begin Y1 := Round(P1.Y); Y2 := Round(P2.Y); if Y1 = Y2 then begin AddSegment(P1.X, P1.Y - Y1, P2.X, P2.Y - Y1, ScanLines[Y1]); end else begin k := (P2.X - P1.X) / (P2.Y - P1.Y); if Y1 < Y2 then begin X := P1.X + (Y1 + 1 - P1.Y) * k; AddSegment(P1.X, P1.Y - Y1, X, 1, ScanLines[Y1]); for Y := Y1 + 1 to Y2 - 1 do begin AddSegment(X, 0, X + k, 1, ScanLines[Y]); X := X + k; end; AddSegment(X, 0, P2.X, P2.Y - Y2, ScanLines[Y2]); end else begin X := P1.X + (Y1 - P1.Y) * k; AddSegment(P1.X, P1.Y - Y1, X, 0, ScanLines[Y1]); for Y := Y1 - 1 downto Y2 + 1 do begin AddSegment(X, 1, X - k, 0, ScanLines[Y]); X := X - k end; AddSegment(X, 1, P2.X, P2.Y - Y2, ScanLines[Y2]); end; end; end; procedure BuildScanLines(const Points: TArrayOfFloatPoint; out ScanLines: TScanLines); var I, J, N, J0, J1, Y, YMin, YMax: Integer; PScanLines: PScanLineArray; begin N := Length(Points); if N <= 2 then Exit; YMin := Round(Points[0].Y); YMax := YMin; for I := 1 to N - 1 do begin Y := Round(Points[I].Y); if YMin > Y then YMin := Y; if YMax < Y then YMax := Y; end; SetLength(ScanLines, YMax - YMin + 2); PScanLines := @ScanLines[-YMin]; {** compute array sizes for each scanline } J0 := Round(Points[0].Y); for I := 1 to N - 1 do begin J1 := J0; J0 := Round(Points[I].Y); if J0 <= J1 then begin Inc(PScanLines[J0].Count); Dec(PScanLines[J1 + 1].Count); end else begin Inc(PScanLines[J1].Count); Dec(PScanLines[J0 + 1].Count); end; end; {** allocate memory } J := 0; for I := 0 to High(ScanLines) do begin Inc(J, ScanLines[I].Count); GetMem(ScanLines[I].Segments, J * SizeOf(TLineSegment)); ScanLines[I].Count := 0; ScanLines[I].Y := YMin + I; end; for I := 0 to N - 2 do begin DivideSegment(Points[I], Points[I + 1], PScanLines); end; end; procedure MergeScanLines(const Src: TScanLines; var Dst: TScanLines); var Temp: TScanLines; I, J, K, SrcCount, DstCount: Integer; begin if Length(Src) = 0 then Exit; SetLength(Temp, Length(Src) + Length(Dst)); I := 0; J := 0; K := 0; while (I <= High(Src)) and (J <= High(Dst)) do begin if Src[I].Y = Dst[J].Y then begin SrcCount := Src[I].Count; DstCount := Dst[J].Count; Temp[K].Count := SrcCount + DstCount; Temp[K].Y := Src[I].Y; GetMem(Temp[K].Segments, Temp[K].Count * SizeOf(TLineSegment)); Move(Src[I].Segments[0], Temp[K].Segments[0], SrcCount * SizeOf(TLineSegment)); Move(Dst[J].Segments[0], Temp[K].Segments[SrcCount], DstCount * SizeOf(TLineSegment)); FreeMem(Src[I].Segments); FreeMem(Dst[J].Segments); Inc(I); Inc(J); end else if Src[I].Y < Dst[J].Y then begin Temp[K] := Src[I]; Inc(I); end else begin Temp[K] := Dst[J]; Inc(J); end; Inc(K); end; while I <= High(Src) do begin Temp[K] := Src[I]; Inc(I); Inc(K); end; while J <= High(Dst) do begin Temp[K] := Dst[J]; Inc(J); Inc(K); end; Dst := Copy(Temp, 0, K); end; procedure RenderScanline(var ScanLine: TScanLine; RenderProc: TRenderSpanProc; Data: Pointer; SpanData: PSingleArray; X1, X2: Integer); var Span: TValueSpan; begin if ScanLine.Count > 0 then begin ExtractSingleSpan(ScanLine, Span, SpanData); if Span.X1 < X1 then Span.X1 := X1; if Span.X2 > X2 then Span.X2 := X2; if Span.X2 < Span.X1 then Exit; RenderProc(Data, Span, ScanLine.Y); FillLongWord(SpanData[Span.X1], Span.X2 - Span.X1 + 1, 0); end; end; procedure RenderPolyPolygon(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; const RenderProc: TRenderSpanProc; Data: Pointer); var ScanLines, Temp: TScanLines; I: Integer; Poly: TArrayOfFloatPoint; SavedRoundMode: TFPURoundingMode; CX1, CX2: Integer; SpanData: PSingleArray; begin if Length(Points) = 0 then Exit; SavedRoundMode := SetRoundMode(rmDown); try Poly := ClosePolygon(ClipPolygon(Points[0], ClipRect)); BuildScanLines(Poly, ScanLines); for I := 1 to High(Points) do begin Poly := ClosePolygon(ClipPolygon(Points[I], ClipRect)); BuildScanLines(Poly, Temp); MergeScanLines(Temp, ScanLines); Temp := nil; end; CX1 := Round(ClipRect.Left); CX2 := -Round(-ClipRect.Right) - 1; I := CX2 - CX1 + 4; GetMem(SpanData, I * SizeOf(Single)); FillLongWord(SpanData^, I, 0); for I := 0 to High(ScanLines) do begin RenderScanline(ScanLines[I], RenderProc, Data, @SpanData[-CX1 + 1], CX1, CX2); FreeMem(ScanLines[I].Segments); end; FreeMem(SpanData); finally SetRoundMode(SavedRoundMode); end; end; procedure RenderPolygon(const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; const RenderProc: TRenderSpanProc; Data: Pointer); begin RenderPolyPolygon(PolyPolygon(Points), ClipRect, RenderProc, Data); end; procedure RenderPolyPolygon(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; const RenderProc: TRenderSpanEvent); begin with TMethod(RenderProc) do RenderPolyPolygon(Points, ClipRect, TRenderSpanProc(Code), Data); end; procedure RenderPolygon(const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; const RenderProc: TRenderSpanEvent); begin with TMethod(RenderProc) do RenderPolygon(Points, ClipRect, TRenderSpanProc(Code), Data); end; end. |
Added src/graphics32/GR32_VPR2.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 | unit GR32_VPR2; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Vectorial Polygon Rasterizer for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * * Portions created by the Initial Developer are Copyright (C) 2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses GR32, GR32_Polygons, GR32_OrdinalMaps; type PIntSpan = ^TIntSpan; TIntSpan = record Min, Max: Integer; end; const STARTSPAN: TIntSpan = (Min: MAXINT; Max: 0); type TPolygonRenderer32VPR2 = class(TPolygonRenderer32) private FOpacityMap: TFloatMap; FXSpan: array of TIntSpan; FYSpan: TIntSpan; procedure AddLineSegment(X1, Y1, X2, Y2: TFloat); overload; procedure DrawBitmap; public constructor Create; override; destructor Destroy; override; procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); override; end; { TPolygonRenderer32VPR2X } TPolygonRenderer32VPR2X = class(TPolygonRenderer32) private FOpacityMap: TIntegerMap; FXSpan: array of TIntSpan; FYSpan: TIntSpan; procedure AddLineSegment(X1, Y1, X2, Y2: TFixed); overload; procedure DrawBitmap; public constructor Create; override; destructor Destroy; override; procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); override; end; implementation uses Math, GR32_VectorUtils, GR32_Math, GR32_LowLevel, GR32_Blend; { TPolygonRenderer32VPR2 } procedure UpdateSpan(var Span: TIntSpan; Value: Integer); {$IFDEF USEINLINING} inline; {$ENDIF} begin if Value < Span.Min then Span.Min := Value; if Value > Span.Max then Span.Max := Value; end; procedure TPolygonRenderer32VPR2.AddLineSegment(X1, Y1, X2, Y2: TFloat); type PFloatArray = ^TFloatArray; TFloatArray = array [0..1] of TFloat; const SGN: array [0..1] of Integer = (1, -1); EPSILON: TFloat = 0.0001; var Dx, Dy, DyDx, DxDy, Xm, Ym, Xn, Yn, t, tX, tY: Double; X, Y, StepX, StepY: Integer; P: PFloatArray; procedure AddSegment(X1, Y1, X2, Y2: TFloat); var Dx, Dy: TFloat; begin Dx := (X1 + X2) * 0.5; Dx := Dx - Round(Dx); Dy := Y2 - Y1; Dx := Dx * Dy; P[0] := P[0] + Dy - Dx; P[1] := P[1] + Dx; end; begin Dx := X2 - X1; Dy := Y2 - Y1; if Dy = 0 then Exit; X := Round(X1); Y := Round(Y1); UpdateSpan(FYSpan, Y); StepX := Ord(Dx < 0); StepY := Ord(Dy < 0); X1 := X1 - StepX; Y1 := Y1 - StepY; X2 := X2 - StepX; Y2 := Y2 - StepY; StepX := SGN[StepX]; StepY := SGN[StepY]; if Dx = 0 then begin Yn := Y1; repeat UpdateSpan(FXSpan[Y], X); P := PFloatArray(FOpacityMap.ValPtr[X, Y]); Ym := Yn; Inc(Y, StepY); Yn := Y; AddSegment(X1, Ym, X1, Yn); until Abs(Y1 - Yn) + EPSILON >= Abs(Dy); AddSegment(X1, Yn, X1, Y2); end else begin DyDx := Dy/Dx; DxDy := Dx/Dy; tX := X + StepX - X1; tY := (Y + StepY - Y1) * DxDy; Xn := X1; Yn := Y1; repeat Xm := Xn; Ym := Yn; UpdateSpan(FXSpan[Y], X); P := PFloatArray(FOpacityMap.ValPtr[X, Y]); if Abs(tX) <= Abs(tY) then begin Inc(X, StepX); t := tX; tX := tX + StepX; end else begin Inc(Y, StepY); t := tY; tY := tY + StepY * DxDy; end; Xn := X1 + t; Yn := Y1 + t * DyDx; AddSegment(Xm, Ym, Xn, Yn); until Abs(t) + EPSILON >= Abs(Dx); AddSegment(Xn, Yn, X2, Y2); end; end; constructor TPolygonRenderer32VPR2.Create; begin inherited Create; FOpacityMap := TFloatMap.Create; end; destructor TPolygonRenderer32VPR2.Destroy; begin FOpacityMap.Free; inherited; end; procedure MakeAlphaNonZeroUP(Coverage: PSingleArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var I: Integer; M, V: Cardinal; Last: TFloat; C: TColor32Entry absolute Color; begin M := C.A * $101; Last := Infinity; for I := 0 to Count - 1 do begin if PInteger(@Last)^ <> PInteger(@Coverage[I])^ then begin Last := Coverage[I]; V := Abs(Round(Last * $10000)); if V > $10000 then V := $10000; V := V * M shr 24; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} C.A := V; end; AlphaValues[I] := Color; end; end; procedure MakeAlphaEvenOddUP(Coverage: PSingleArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var I: Integer; M, V: Cardinal; Last: TFloat; C: TColor32Entry absolute Color; begin M := C.A * $101; Last := Infinity; for I := 0 to Count - 1 do begin if PInteger(@Last)^ <> PInteger(@Coverage[I])^ then begin Last := Coverage[I]; V := Abs(Round(Coverage[I] * $10000)); V := V and $01ffff; if V >= $10000 then V := V xor $1ffff; V := V * M shr 24; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} C.A := V; end; AlphaValues[I] := Color; end; end; {$IFDEF UseStackAlloc}{$W+}{$ENDIF} procedure TPolygonRenderer32VPR2.DrawBitmap; const FillProcs: array [TPolyFillMode] of TFillProc = (MakeAlphaEvenOddUP, MakeAlphaNonZeroUP); var I, N: Integer; Dst: PColor32Array; Src: PFloatArray; P: PIntSpan; FillProc: TFillProc; FG: PColor32Array; begin {$IFDEF UseStackAlloc} FG := StackAlloc(Bitmap.Width * SizeOf(TColor32)); {$ELSE} GetMem(FG, Bitmap.Width * SizeOf(TColor32)); {$ENDIF} FillProc := FillProcs[FillMode]; FYSpan.Max := Min(FYSpan.Max, Bitmap.Height - 1); Assert(FYSpan.Min >= 0); Assert(FYSpan.Max < Bitmap.Height); for I := FYSpan.Min to FYSpan.Max do begin P := @FXSpan[I]; P.Max := Min(P.Max + 1, Bitmap.Width - 1); if P.Max < P.Min then Continue; N := P.Max - P.Min + 1; Dst := Bitmap.Scanline[I]; Src := PFloatArray(FOpacityMap.ValPtr[0, I]); // 1. Cumulative sum CumSum(@Src[P.Min], N); // 2. Convert opacity to colors FillProc(@Src[P.Min], @FG[P.Min], N, Color); // 3. Blend colors BlendLine(@FG[P.Min], @Dst[P.Min], N); // 4. Clear opacity map FillLongWord(Src[P.Min], N, 0); end; {$IFDEF UseStackAlloc} StackFree(FG); {$ELSE} FreeMem(FG); {$ENDIF} end; {$IFDEF UseStackAlloc}{$W-}{$ENDIF} procedure TPolygonRenderer32VPR2.PolyPolygonFS( const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); var APoints: TArrayOfFloatPoint; I, J, H: Integer; SavedRoundMode: TFPURoundingMode; R: TFloatRect; begin FYSpan := STARTSPAN; SavedRoundMode := SetRoundMode(rmDown); try FOpacityMap.SetSize(Bitmap.Width + 1, Bitmap.Height); // temporary fix for floating point rounding errors R := ClipRect; R.Right := R.Right - 0.0001; R.Bottom := R.Bottom - 0.0001; SetLength(FXSpan, Bitmap.Height); for I := 0 to High(FXSpan) do FXSpan[I] := STARTSPAN; for I := 0 to High(Points) do begin APoints := ClipPolygon(Points[I], R); H := High(APoints); if H <= 0 then Continue; for J := 0 to H - 1 do AddLineSegment(APoints[J].X, APoints[J].Y, APoints[J + 1].X, APoints[J + 1].Y); AddLineSegment(APoints[H].X, APoints[H].Y, APoints[0].X, APoints[0].Y); end; DrawBitmap; finally SetRoundMode(SavedRoundMode); end; end; //============================================================================// procedure TPolygonRenderer32VPR2X.AddLineSegment(X1, Y1, X2, Y2: TFixed); type PFixedArray = ^TFixedArray; TFixedArray = array [0..1] of TFixed; const SGN: array [0..1] of Integer = (1, -1); var Dx, Dy, DyDx, DxDy, t, tX, tY, Xm, Ym, Xn, Yn: TFixed; X, Y, StepX, StepY: Integer; P: PFixedArray; procedure AddSegment(X1, Y1, X2, Y2: TFixed); var Dx, Dy: TFixed; begin Dx := (X1 + X2) shr 1; Dx := Dx and $ffff; Dy := Y2 - Y1; Dx := FixedMul(Dx, Dy); P[0] := P[0] + Dy - Dx; P[1] := P[1] + Dx; end; begin Dx := X2 - X1; Dy := Y2 - Y1; if Dy = 0 then Exit; X := FixedFloor(X1); Y := FixedFloor(Y1); UpdateSpan(FYSpan, Y); StepX := Ord(Dx < 0); StepY := Ord(Dy < 0); X1 := X1 - StepX * FixedOne; Y1 := Y1 - StepY * FixedOne; X2 := X2 - StepX * FixedOne; Y2 := Y2 - StepY * FixedOne; StepX := SGN[StepX]; StepY := SGN[StepY]; if Dx = 0 then begin Yn := Y1; repeat UpdateSpan(FXSpan[Y], X); P := PFixedArray(FOpacityMap.ValPtr[X, Y]); Ym := Yn; Inc(Y, StepY); Yn := Y * FixedOne; AddSegment(X1, Ym, X1, Yn); until Abs(Y1 - Yn) >= Abs(Dy); AddSegment(X1, Yn, X1, Y2); end else begin DyDx := FixedDiv(Dy, Dx); DxDy := FixedDiv(Dx, Dy); tX := (X + StepX) * FixedOne - X1; tY := FixedMul((Y + StepY) * FixedOne - Y1, DxDy); Xn := X1; Yn := Y1; repeat Xm := Xn; Ym := Yn; UpdateSpan(FXSpan[Y], X); P := PFixedArray(FOpacityMap.ValPtr[X, Y]); if Abs(tX) <= Abs(tY) then begin Inc(X, StepX); t := tX; tX := tX + StepX*FixedOne; end else begin Inc(Y, StepY); t := tY; tY := tY + StepY * DxDy; end; Xn := X1 + t; Yn := Y1 + FixedMul(t, DyDx); AddSegment(Xm, Ym, Xn, Yn); until Abs(t) >= Abs(Dx); AddSegment(Xn, Yn, X2, Y2); end; end; procedure CumSumX(PSrc: PFixedArray; N: Integer); var I: Integer; begin for I := 1 to N - 1 do Inc(PSrc[I], PSrc[I - 1]); end; procedure MakeAlphaNonZeroUPX(Coverage: PFixedArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var I, V, M, Last: Integer; C: TColor32Entry absolute Color; begin M := C.A * $101; Last := MaxInt; for I := 0 to Count - 1 do begin if Last <> Coverage[I] then begin V := Abs(Coverage[I]); if V > $ffff then V := $ffff; V := V * M shr 24; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} C.A := V; end; AlphaValues[I] := Color; end; end; procedure MakeAlphaEvenOddUPX(Coverage: PFixedArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); var I, V, M, Last: Integer; C: TColor32Entry absolute Color; begin M := C.A * $101; Last := MaxInt; for I := 0 to Count - 1 do begin if Last <> Coverage[I] then begin V := Abs(Coverage[I]); V := V and $01ffff; if V >= $10000 then V := V xor $1ffff; V := V * M shr 24; {$IFDEF USEGR32GAMMA} V := GAMMA_TABLE[V]; {$ENDIF} C.A := V; end; AlphaValues[I] := Color; end; end; {$IFDEF UseStackAlloc}{$W+}{$ENDIF} procedure TPolygonRenderer32VPR2X.DrawBitmap; type TFillProcX = procedure(Coverage: PFixedArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); const FillProcs: array [TPolyFillMode] of TFillProcX = (MakeAlphaEvenOddUPX, MakeAlphaNonZeroUPX); var I, N: Integer; Dst: PColor32Array; Src: PFixedArray; P: PIntSpan; FillProc: TFillProcX; FG: PColor32Array; begin {$IFDEF UseStackAlloc} FG := StackAlloc(Bitmap.Width * SizeOf(TColor32)); {$ELSE} GetMem(FG, Bitmap.Width * SizeOf(TColor32)); {$ENDIF} FillProc := FillProcs[FillMode]; FYSpan.Max := Min(FYSpan.Max, Bitmap.Height - 1); Assert(FYSpan.Min >= 0); Assert(FYSpan.Max < Bitmap.Height); for I := FYSpan.Min to FYSpan.Max do begin P := @FXSpan[I]; P.Max := Min(P.Max + 1, Bitmap.Width - 1); if P.Max < P.Min then Continue; N := P.Max - P.Min + 1; Dst := Bitmap.Scanline[I]; Src := PFixedArray(FOpacityMap.ValPtr[0, I]); // 1. Cumulative sum CumSumX(@Src[P.Min], N); // 2. Convert opacity to colors FillProc(@Src[P.Min], @FG[P.Min], N, Color); // 3. Blend colors BlendLine(@FG[P.Min], @Dst[P.Min], N); // 4. Clear opacity map FillLongWord(Src[P.Min], N, 0); end; {$IFDEF UseStackAlloc} StackFree(FG); {$ELSE} FreeMem(FG); {$ENDIF} end; {$IFDEF UseStackAlloc}{$W-}{$ENDIF} procedure TPolygonRenderer32VPR2X.PolyPolygonFS( const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); var APoints: TArrayOfFloatPoint; I, J, H: Integer; SavedRoundMode: TFPURoundingMode; R: TFloatRect; begin FYSpan := STARTSPAN; FOpacityMap.SetSize(Bitmap.Width + 1, Bitmap.Height); // temporary fix for floating point rounding errors R := ClipRect; InflateRect(R, -0.05, -0.05); SetLength(FXSpan, Bitmap.Height); for I := 0 to High(FXSpan) do FXSpan[I] := STARTSPAN; for I := 0 to High(Points) do begin APoints := ClipPolygon(Points[I], R); H := High(APoints); if H <= 0 then Continue; for J := 0 to H - 1 do AddLineSegment(Fixed(APoints[J].X), Fixed(APoints[J].Y), Fixed(APoints[J + 1].X), Fixed(APoints[J + 1].Y)); AddLineSegment(Fixed(APoints[H].X), Fixed(APoints[H].Y), Fixed(APoints[0].X), Fixed(APoints[0].Y)); end; DrawBitmap; end; constructor TPolygonRenderer32VPR2X.Create; begin inherited Create; FOpacityMap := TIntegerMap.Create; end; destructor TPolygonRenderer32VPR2X.Destroy; begin FOpacityMap.Free; inherited Destroy; end; initialization RegisterPolygonRenderer(TPolygonRenderer32VPR2); RegisterPolygonRenderer(TPolygonRenderer32VPR2X); end. |
Added src/graphics32/GR32_VectorMaps.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 | unit GR32_VectorMaps; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is GR32_VectorMaps * * The Initial Developer of the Original Code is * Michael Hansen <dyster_tid@hotmail.com> * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Mattias Andersson <mattias@centaurix.com> * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} {$IFDEF Windows} Windows, {$ENDIF} {$ELSE} Windows, {$ENDIF} Classes, GR32; type TFixedVector = TFixedPoint; PFixedVector = ^TFixedVector; TFloatVector = TFloatPoint; PFloatVector = ^TFloatVector; TArrayOfFixedVector = array of TFixedVector; PArrayOfFixedVector = ^TArrayOfFixedVector; TArrayOfFloatVector = array of TFloatVector; PArrayOfFloatVector = ^TArrayOfFixedVector; type TVectorCombineMode = (vcmAdd, vcmReplace, vcmCustom); TVectorCombineEvent= procedure(F, P: TFixedVector; var B: TFixedVector) of object; TVectorMap = class(TCustomMap) private FVectors: TArrayOfFixedVector; FOnVectorCombine: TVectorCombineEvent; FVectorCombineMode: TVectorCombineMode; function GetVectors: PFixedPointArray; function GetFixedVector(X,Y: Integer): TFixedVector; function GetFixedVectorS(X,Y: Integer): TFixedVector; function GetFixedVectorX(X,Y: TFixed): TFixedVector; function GetFixedVectorXS(X,Y: TFixed): TFixedVector; function GetFloatVector(X,Y: Integer): TFloatVector; function GetFloatVectorS(X,Y: Integer): TFloatVector; function GetFloatVectorF(X,Y: Single): TFloatVector; function GetFloatVectorFS(X,Y: Single): TFloatVector; procedure SetFixedVector(X,Y: Integer; const Point: TFixedVector); procedure SetFixedVectorS(X,Y: Integer; const Point: TFixedVector); procedure SetFixedVectorX(X,Y: TFixed; const Point: TFixedVector); procedure SetFixedVectorXS(X,Y: TFixed; const Point: TFixedVector); procedure SetFloatVector(X,Y: Integer; const Point: TFloatVector); procedure SetFloatVectorS(X,Y: Integer; const Point: TFloatVector); procedure SetFloatVectorF(X,Y: Single; const Point: TFloatVector); procedure SetFloatVectorFS(X,Y: Single; const Point: TFloatVector); procedure SetVectorCombineMode(const Value: TVectorCombineMode); protected procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; public destructor Destroy; override; procedure Clear; procedure Merge(DstLeft, DstTop: Integer; Src: TVectorMap; SrcRect: TRect); property Vectors: PFixedPointArray read GetVectors; function BoundsRect: TRect; function GetTrimmedBounds: TRect; function Empty: Boolean; override; procedure LoadFromFile(const FileName: string); procedure SaveToFile(const FileName: string); property FixedVector[X, Y: Integer]: TFixedVector read GetFixedVector write SetFixedVector; default; property FixedVectorS[X, Y: Integer]: TFixedVector read GetFixedVectorS write SetFixedVectorS; property FixedVectorX[X, Y: TFixed]: TFixedVector read GetFixedVectorX write SetFixedVectorX; property FixedVectorXS[X, Y: TFixed]: TFixedVector read GetFixedVectorXS write SetFixedVectorXS; property FloatVector[X, Y: Integer]: TFloatVector read GetFloatVector write SetFloatVector; property FloatVectorS[X, Y: Integer]: TFloatVector read GetFloatVectorS write SetFloatVectorS; property FloatVectorF[X, Y: Single]: TFloatVector read GetFloatVectorF write SetFloatVectorF; property FloatVectorFS[X, Y: Single]: TFloatVector read GetFloatVectorFS write SetFloatVectorFS; published property VectorCombineMode: TVectorCombineMode read FVectorCombineMode write SetVectorCombineMode; property OnVectorCombine: TVectorCombineEvent read FOnVectorCombine write FOnVectorCombine; end; implementation uses GR32_Lowlevel, GR32_Math, SysUtils; resourcestring RCStrCantAllocateVectorMap = 'Can''t allocate VectorMap!'; RCStrBadFormat = 'Bad format - Photoshop .msh expected!'; RCStrFileNotFound = 'File not found!'; RCStrSrcIsEmpty = 'Src is empty!'; RCStrBaseIsEmpty = 'Base is empty!'; { TVectorMap } function CombineVectorsReg(const A, B: TFixedVector; Weight: TFixed): TFixedVector; begin Result.X := FixedCombine(Weight, B.X, A.X); Result.Y := FixedCombine(Weight, B.Y, A.Y); end; procedure CombineVectorsMem(const A: TFixedVector;var B: TFixedVector; Weight: TFixed); begin B.X := FixedCombine(Weight, B.X, A.X); B.Y := FixedCombine(Weight, B.Y, A.Y); end; function TVectorMap.BoundsRect: TRect; begin Result := Rect(0, 0, Width, Height); end; procedure TVectorMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); begin inherited; FVectors := nil; Width := 0; Height := 0; SetLength(FVectors, NewWidth * NewHeight); if (NewWidth > 0) and (NewHeight > 0) then begin if FVectors = nil then raise Exception.Create(RCStrCantAllocateVectorMap); FillLongword(FVectors[0], NewWidth * NewHeight * 2, 0); end; Width := NewWidth; Height := NewHeight; end; procedure TVectorMap.Clear; begin FillLongword(FVectors[0], Width * Height * 2, 0); end; destructor TVectorMap.Destroy; begin Lock; try SetSize(0, 0); finally Unlock; end; inherited; end; function TVectorMap.GetVectors: PFixedPointArray; begin Result := @FVectors[0]; end; function TVectorMap.GetFloatVector(X, Y: Integer): TFloatVector; begin Result := FloatPoint(FVectors[X + Y * Width]); end; function TVectorMap.GetFloatVectorF(X, Y: Single): TFloatVector; begin Result := FloatPoint(GetFixedVectorX(Fixed(X), Fixed(Y))); end; function TVectorMap.GetFloatVectorFS(X, Y: Single): TFloatVector; begin Result := FloatPoint(GetFixedVectorXS(Fixed(X), Fixed(Y))); end; function TVectorMap.GetFloatVectorS(X, Y: Integer): TFloatVector; begin if (X >= 0) and (Y >= 0) and (X < Width) and (Y < Height) then Result := GetFloatVector(X,Y) else begin Result.X := 0; Result.Y := 0; end; end; function TVectorMap.GetFixedVector(X, Y: Integer): TFixedVector; begin Result := FVectors[X + Y * Width]; end; function TVectorMap.GetFixedVectorS(X, Y: Integer): TFixedVector; begin if (X >= 0) and (Y >= 0) and (X < Width) and (Y < Height) then Result := GetFixedVector(X,Y) else begin Result.X := 0; Result.Y := 0; end; end; function TVectorMap.GetFixedVectorX(X, Y: TFixed): TFixedVector; const Next = SizeOf(TFixedVector); var WX,WY: TFixed; W, H: Integer; P: Pointer; begin WX := TFixedRec(X).Int; WY := TFixedRec(Y).Int; W := Width; H := Height; if (WX >= 0) and (WX <= W - 1) and (WY >= 0) and (WY <= H - 1) then begin P := @FVectors[WX + WY * W]; if (WY = H - 1) then W := 0 else W := W * Next; if (WX = W - 1) then H := 0 else H := Next; WX := TFixedRec(X).Frac; WY := TFixedRec(Y).Frac; {$IFDEF HAS_NATIVEINT} Result := CombineVectorsReg(CombineVectorsReg(PFixedPoint(P)^, PFixedPoint(NativeUInt(P) + NativeUInt(H))^, WX), CombineVectorsReg( PFixedPoint(NativeUInt(P) + NativeUInt(W))^, PFixedPoint(NativeUInt(P) + NativeUInt(W + H))^, WX), WY); {$ELSE} Result := CombineVectorsReg(CombineVectorsReg(PFixedPoint(P)^, PFixedPoint(Cardinal(P) + Cardinal(H))^, WX), CombineVectorsReg( PFixedPoint(Cardinal(P) + Cardinal(W))^, PFixedPoint(Cardinal(P) + Cardinal(W) + Cardinal(H))^, WX), WY); {$ENDIF} end else begin Result.X := 0; Result.Y := 0; end; end; function TVectorMap.GetFixedVectorXS(X, Y: TFixed): TFixedVector; var WX,WY: TFixed; begin WX := TFixedRec(X).Frac; X := TFixedRec(X).Int; WY := TFixedRec(Y).Frac; Y := TFixedRec(Y).Int; Result := CombineVectorsReg(CombineVectorsReg(FixedVectorS[X,Y], FixedVectorS[X + 1,Y], WX), CombineVectorsReg(FixedVectorS[X,Y + 1], FixedVectorS[X + 1,Y + 1], WX), WY); end; function TVectorMap.Empty: Boolean; begin Result := false; if (Width = 0) or (Height = 0) or (FVectors = nil) then Result := True; end; const MeshIdent = 'yfqLhseM'; type {TVectorMap supports the photoshop liquify mesh fileformat .msh} TPSLiquifyMeshHeader = record Pad0 : dword; Ident : array [0..7] of Char; Pad1 : dword; Width : dword; Height: dword; end; procedure TVectorMap.LoadFromFile(const FileName: string); procedure ConvertVertices; var I: Integer; begin for I := 0 to Length(FVectors) - 1 do begin //Not a mistake! Converting physical mem. directly to avoid temporary floating point buffer //Do no change to PFloat.. the type is relative to the msh format. FVectors[I].X := Fixed(PSingle(@FVectors[I].X)^); FVectors[I].Y := Fixed(PSingle(@FVectors[I].Y)^); end; end; var Header: TPSLiquifyMeshHeader; MeshFile: File; begin If FileExists(Filename) then try AssignFile(MeshFile, FileName); Reset(MeshFile, 1); BlockRead(MeshFile, Header, SizeOf(TPSLiquifyMeshHeader)); if LowerCase(string(Header.Ident)) <> LowerCase(MeshIdent) then Exception.Create(RCStrBadFormat); with Header do begin SetSize(Width, Height); BlockRead(MeshFile, FVectors[0], Width * Height * SizeOf(TFixedVector)); ConvertVertices; end; finally CloseFile(MeshFile); end else Exception.Create(RCStrFileNotFound); end; procedure TVectorMap.Merge(DstLeft, DstTop: Integer; Src: TVectorMap; SrcRect: TRect); var I,J,P: Integer; DstRect: TRect; Progression: TFixedVector; ProgressionX, ProgressionY: TFixed; CombineCallback: TVectorCombineEvent; DstPtr : PFixedPointArray; SrcPtr : PFixedPoint; begin if Src.Empty then Exception.Create(RCStrSrcIsEmpty); if Empty then Exception.Create(RCStrBaseIsEmpty); IntersectRect( SrcRect, Src.BoundsRect, SrcRect); DstRect.Left := DstLeft; DstRect.Top := DstTop; DstRect.Right := DstLeft + (SrcRect.Right - SrcRect.Left); DstRect.Bottom := DstTop + (SrcRect.Bottom - SrcRect.Top); IntersectRect(DstRect, BoundsRect, DstRect); if IsRectEmpty(DstRect) then Exit; P := SrcRect.Top * Src.Width; Progression.Y := - FixedOne; case Src.FVectorCombineMode of vcmAdd: begin for I := DstRect.Top to DstRect.Bottom do begin // Added ^ for FPC DstPtr := @GetVectors^[I * Width]; SrcPtr := @Src.GetVectors^[SrcRect.Left + P]; for J := DstRect.Left to DstRect.Right do begin Inc(SrcPtr^.X, DstPtr[J].X); Inc(SrcPtr^.Y, DstPtr[J].Y); Inc(SrcPtr); end; Inc(P, Src.Width); end; end; vcmReplace: begin for I := DstRect.Top to DstRect.Bottom do begin // Added ^ for FPC DstPtr := @GetVectors^[I * Width]; SrcPtr := @Src.GetVectors^[SrcRect.Left + P]; for J := DstRect.Left to DstRect.Right do begin SrcPtr^.X := DstPtr[J].X; SrcPtr^.Y := DstPtr[J].Y; Inc(SrcPtr); end; Inc(P, Src.Width); end; end; else CombineCallback := Src.FOnVectorCombine; ProgressionX := Fixed(2 / (DstRect.Right - DstRect.Left - 1)); ProgressionY := Fixed(2 / (DstRect.Bottom - DstRect.Top - 1)); for I := DstRect.Top to DstRect.Bottom do begin Progression.X := - FixedOne; // Added ^ for FPC DstPtr := @GetVectors^[I * Width]; SrcPtr := @Src.GetVectors^[SrcRect.Left + P]; for J := DstRect.Left to DstRect.Right do begin CombineCallback(SrcPtr^, Progression, DstPtr[J]); Inc(SrcPtr); Inc(Progression.X, ProgressionX); end; Inc(P, Src.Width); Inc(Progression.Y, ProgressionY); end; end; end; procedure TVectorMap.SaveToFile(const FileName: string); procedure ConvertVerticesX; var I: Integer; begin for I := 0 to Length(FVectors) - 1 do begin //Not a mistake! Converting physical mem. directly to avoid temporary floating point buffer //Do no change to PFloat.. the type is relative to the msh format. FVectors[I].X := Fixed(PSingle(@FVectors[I].X)^); FVectors[I].Y := Fixed(PSingle(@FVectors[I].Y)^); end; end; procedure ConvertVerticesF; var I: Integer; {$IFDEF COMPILERRX1} f: single; {$ENDIF} begin for I := 0 to Length(FVectors) - 1 do begin //Not a mistake! Converting physical mem. directly to avoid temporary floating point buffer //Do no change to PFloat.. the type is relative to the msh format. //Workaround for Delphi 10.1 Internal Error C6949 ... {$IFDEF COMPILERRX1} f := FVectors[I].X * FixedToFloat; FVectors[I].X := PInteger(@f)^; f := FVectors[I].Y * FixedToFloat; FVectors[I].Y := PInteger(@f)^; {$ELSE} PSingle(@FVectors[I].X)^ := FVectors[I].X * FixedToFloat; PSingle(@FVectors[I].Y)^ := FVectors[I].Y * FixedToFloat; {$ENDIF} end; end; var Header: TPSLiquifyMeshHeader; MeshFile: File; Pad: Cardinal; begin try AssignFile(MeshFile, FileName); Rewrite(MeshFile, 1); with Header do begin Pad0 := $02000000; Ident := MeshIdent; Pad1 := $00000002; Width := Self.Width; Height := Self.Height; end; BlockWrite(MeshFile, Header, SizeOf(TPSLiquifyMeshHeader)); with Header do begin ConvertVerticesF; BlockWrite(MeshFile, FVectors[0], Length(FVectors) * SizeOf(TFixedVector)); ConvertVerticesX; end; if Odd(Length(FVectors) * SizeOf(TFixedVector) - 1) then begin Pad := $00000000; BlockWrite(MeshFile, Pad, 4); BlockWrite(MeshFile, Pad, 4); end; finally CloseFile(MeshFile); end; end; procedure TVectorMap.SetFloatVector(X, Y: Integer; const Point: TFloatVector); begin FVectors[X + Y * Width] := FixedPoint(Point); end; procedure TVectorMap.SetFloatVectorF(X, Y: Single; const Point: TFloatVector); begin SetFixedVectorX(Fixed(X), Fixed(Y), FixedPoint(Point)); end; procedure TVectorMap.SetFloatVectorFS(X, Y: Single; const Point: TFloatVector); begin SetFixedVectorXS(Fixed(X), Fixed(Y), FixedPoint(Point)); end; procedure TVectorMap.SetFloatVectorS(X, Y: Integer; const Point: TFloatVector); begin if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then FVectors[X + Y * Width] := FixedPoint(Point); end; procedure TVectorMap.SetFixedVector(X, Y: Integer; const Point: TFixedVector); begin FVectors[X + Y * Width] := Point; end; procedure TVectorMap.SetFixedVectorS(X, Y: Integer; const Point: TFixedVector); begin if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then FVectors[X + Y * Width] := Point; end; procedure TVectorMap.SetFixedVectorX(X, Y: TFixed; const Point: TFixedVector); var flrx, flry, celx, cely: Integer; P: PFixedPoint; begin flrx := TFixedRec(X).Frac; celx := flrx xor $FFFF; flry := TFixedRec(Y).Frac; cely := flry xor $FFFF; P := @FVectors[TFixedRec(X).Int + TFixedRec(Y).Int * Width]; CombineVectorsMem(Point, P^, FixedMul(celx, cely)); Inc(P); CombineVectorsMem(Point, P^, FixedMul(flrx, cely)); Inc(P, Width); CombineVectorsMem(Point, P^, FixedMul(flrx, flry)); Dec(P); CombineVectorsMem(Point, P^, FixedMul(celx, flry)); end; procedure TVectorMap.SetFixedVectorXS(X, Y: TFixed; const Point: TFixedVector); var flrx, flry, celx, cely: Integer; P: PFixedPoint; begin if (X < -$10000) or (Y < -$10000) then Exit; flrx := TFixedRec(X).Frac; X := TFixedRec(X).Int; flry := TFixedRec(Y).Frac; Y := TFixedRec(Y).Int; if (X >= Width) or (Y >= Height) then Exit; celx := flrx xor $FFFF; cely := flry xor $FFFF; P := @FVectors[X + Y * Width]; if (X >= 0) and (Y >= 0)then begin CombineVectorsMem(Point, P^, FixedMul(celx, cely) ); Inc(P); CombineVectorsMem(Point, P^, FixedMul(flrx, cely) ); Inc(P, Width); CombineVectorsMem(Point, P^, FixedMul(flrx, flry) ); Dec(P); CombineVectorsMem(Point, P^, FixedMul(celx, flry) ); end else begin if (X >= 0) and (Y >= 0) then CombineVectorsMem(Point, P^, FixedMul(celx, cely)); Inc(P); if (X < Width - 1) and (Y >= 0) then CombineVectorsMem(Point, P^, FixedMul(flrx, cely)); Inc(P, Width); if (X < Width - 1) and (Y < Height - 1) then CombineVectorsMem(Point, P^, FixedMul(flrx, flry)); Dec(P); if (X >= 0) and (Y < Height - 1) then CombineVectorsMem(Point, P^, FixedMul(celx, flry)); end; end; procedure TVectorMap.SetVectorCombineMode(const Value: TVectorCombineMode); begin if FVectorCombineMode <> Value then begin FVectorCombineMode := Value; Changed; end; end; function TVectorMap.GetTrimmedBounds: TRect; var J: Integer; VectorPtr : PFixedVector; label TopDone, BottomDone, LeftDone, RightDone; begin with Result do begin //Find Top Top := 0; VectorPtr := @Vectors[Top]; repeat if Int64(VectorPtr^) <> 0 then goto TopDone; Inc(VectorPtr); Inc(Top); until Top = Self.Width * Self.Height; TopDone: Top := Top div Self.Width; //Find Bottom Bottom := Self.Width * Self.Height - 1; VectorPtr := @Vectors[Bottom]; repeat if Int64(VectorPtr^) <> 0 then goto BottomDone; Dec(VectorPtr); Dec(Bottom); until Bottom < 0; BottomDone: Bottom := Bottom div Self.Width - 1; //Find Left Left := 0; repeat J := Top; repeat if Int64(FixedVector[Left, J]) <> 0 then goto LeftDone; Inc(J); until J >= Bottom; Inc(Left) until Left >= Self.Width; LeftDone: //Find Right Right := Self.Width - 1; repeat J := Bottom; repeat if Int64(FixedVector[Right, J]) <> 0 then goto RightDone; Dec(J); until J <= Top; Dec(Right) until Right <= Left; end; RightDone: if IsRectEmpty(Result) then Result := Rect(0, 0, 0, 0); end; end. |
Added src/graphics32/GR32_VectorUtils.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 | unit GR32_VectorUtils; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Vectorial Polygon Rasterizer for Graphics32 * * The Initial Developer of the Original Code is * Mattias Andersson <mattias@centaurix.com> * * Portions created by the Initial Developer are Copyright (C) 2008-2012 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} {$BOOLEVAL OFF} uses Math, GR32, GR32_Transforms, GR32_Polygons{$IFDEF FPC}, Types{$ENDIF}; const DEFAULT_MITER_LIMIT = 4.0; DEFAULT_MITER_LIMIT_FIXED = $40000; TWOPI = 2 * Pi; function InSignedRange(const X, X1, X2: TFloat): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function InSignedRange(const X, X1, X2: TFixed): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function OverlapExclusive(const X1, X2, Y1, Y2: TFloat): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function OverlapExclusive(const Pt1, Pt2: TFloatPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function OverlapExclusive(const X1, X2, Y1, Y2: TFixed): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function OverlapExclusive(const Pt1, Pt2: TFixedPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function OverlapInclusive(const X1, X2, Y1, Y2: TFloat): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function OverlapInclusive(const Pt1, Pt2: TFloatPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function OverlapInclusive(const X1, X2, Y1, Y2: TFixed): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function OverlapInclusive(const Pt1, Pt2: TFixedPoint): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Intersect(const A1, A2, B1, B2: TFloatPoint; out P: TFloatPoint): Boolean; overload; function Intersect(const A1, A2, B1, B2: TFixedPoint; out P: TFixedPoint): Boolean; overload; function FindNearestPointIndex(Point: TFloatPoint; Points: TArrayOfFloatPoint): Integer; overload; function FindNearestPointIndex(Point: TFixedPoint; Points: TArrayOfFixedPoint): Integer; overload; function VertexReduction(Points: TArrayOfFloatPoint; Epsilon: TFloat = 1): TArrayOfFloatPoint; overload; function VertexReduction(Points: TArrayOfFixedPoint; Epsilon: TFixed = FixedOne): TArrayOfFixedPoint; overload; function ClosePolygon(const Points: TArrayOfFloatPoint): TArrayOfFloatPoint; overload; function ClosePolygon(const Points: TArrayOfFixedPoint): TArrayOfFixedPoint; overload; function ClipLine(var X1, Y1, X2, Y2: Integer; MinX, MinY, MaxX, MaxY: Integer): Boolean; overload; function ClipLine(var X1, Y1, X2, Y2: TFloat; MinX, MinY, MaxX, MaxY: TFloat): Boolean; overload; function ClipLine(var X1, Y1, X2, Y2: TFixed; MinX, MinY, MaxX, MaxY: TFixed): Boolean; overload; function ClipLine(var P1, P2: TPoint; const ClipRect: TRect): Boolean; overload; function ClipLine(var P1, P2: TFloatPoint; const ClipRect: TFloatRect): Boolean; overload; function ClipLine(var P1, P2: TFixedPoint; const ClipRect: TFixedRect): Boolean; overload; procedure Extract(Src: TArrayOfFloat; Indexes: TArrayOfInteger; out Dst: TArrayOfFloat); overload; procedure Extract(Src: TArrayOfFixed; Indexes: TArrayOfInteger; out Dst: TArrayOfFixed); overload; procedure FastMergeSort(const Values: TArrayOfFloat; out Indexes: TArrayOfInteger); overload; procedure FastMergeSort(const Values: TArrayOfFixed; out Indexes: TArrayOfInteger); overload; type TTriangleVertexIndices = array [0 .. 2] of Integer; TArrayOfTriangleVertexIndices = array of TTriangleVertexIndices; function DelaunayTriangulation(Points: TArrayOfFloatPoint): TArrayOfTriangleVertexIndices; function BuildNormals(const Points: TArrayOfFloatPoint): TArrayOfFloatPoint; overload; function BuildNormals(const Points: TArrayOfFixedPoint): TArrayOfFixedPoint; overload; function Grow(const Points: TArrayOfFloatPoint; const Normals: TArrayOfFloatPoint; const Delta: TFloat; JoinStyle: TJoinStyle = jsMiter; Closed: Boolean = True; MiterLimit: TFloat = DEFAULT_MITER_LIMIT): TArrayOfFloatPoint; overload; function Grow(const Points: TArrayOfFloatPoint; const Delta: TFloat; JoinStyle: TJoinStyle = jsMiter; Closed: Boolean = True; MiterLimit: TFloat = DEFAULT_MITER_LIMIT): TArrayOfFloatPoint; overload; function Grow(const Points: TArrayOfFixedPoint; const Normals: TArrayOfFixedPoint; const Delta: TFixed; JoinStyle: TJoinStyle = jsMiter; Closed: Boolean = True; MiterLimit: TFixed = DEFAULT_MITER_LIMIT_FIXED): TArrayOfFixedPoint; overload; function Grow(const Points: TArrayOfFixedPoint; const Delta: TFixed; JoinStyle: TJoinStyle = jsMiter; Closed: Boolean = True; MiterLimit: TFixed = DEFAULT_MITER_LIMIT_FIXED): TArrayOfFixedPoint; overload; function ReversePolygon(const Points: TArrayOfFloatPoint): TArrayOfFloatPoint; overload; function ReversePolygon(const Points: TArrayOfFixedPoint): TArrayOfFixedPoint; overload; function BuildPolyline(const Points: TArrayOfFloatPoint; StrokeWidth: TFloat; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = DEFAULT_MITER_LIMIT): TArrayOfFloatPoint; overload; function BuildPolyPolyLine(const Points: TArrayOfArrayOfFloatPoint; Closed: Boolean; StrokeWidth: TFloat; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFloat = DEFAULT_MITER_LIMIT): TArrayOfArrayOfFloatPoint; overload; function BuildPolyline(const Points: TArrayOfFixedPoint; StrokeWidth: TFixed; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFixed = DEFAULT_MITER_LIMIT_FIXED): TArrayOfFixedPoint; overload; function BuildPolyPolyLine(const Points: TArrayOfArrayOfFixedPoint; Closed: Boolean; StrokeWidth: TFixed; JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; MiterLimit: TFixed = DEFAULT_MITER_LIMIT_FIXED): TArrayOfArrayOfFixedPoint; overload; function BuildDashedLine(const Points: TArrayOfFloatPoint; const DashArray: TArrayOfFloat; DashOffset: TFloat = 0; Closed: Boolean = False): TArrayOfArrayOfFloatPoint; overload; function BuildDashedLine(const Points: TArrayOfFixedPoint; const DashArray: TArrayOfFixed; DashOffset: TFixed = 0; Closed: Boolean = False): TArrayOfArrayOfFixedPoint; overload; function ClipPolygon(const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect): TArrayOfFloatPoint; overload; function ClipPolygon(const Points: TArrayOfFixedPoint; const ClipRect: TFixedRect): TArrayOfFixedPoint; overload; function CatPolyPolygon(const P1, P2: TArrayOfArrayOfFloatPoint): TArrayOfArrayOfFloatPoint; overload; function CatPolyPolygon(const P1, P2: TArrayOfArrayOfFixedPoint): TArrayOfArrayOfFixedPoint; overload; function CalculateCircleSteps(Radius: TFloat): Cardinal; {$IFDEF USEINLINING} inline; {$ENDIF} function BuildArc(const P: TFloatPoint; StartAngle, EndAngle, Radius: TFloat; Steps: Integer): TArrayOfFloatPoint; overload; function BuildArc(const P: TFloatPoint; StartAngle, EndAngle, Radius: TFloat): TArrayOfFloatPoint; overload; function BuildArc(const P: TFixedPoint; StartAngle, EndAngle, Radius: TFloat; Steps: Integer): TArrayOfFixedPoint; overload; function BuildArc(const P: TFixedPoint; StartAngle, EndAngle, Radius: TFloat): TArrayOfFixedPoint; overload; function Line(const P1, P2: TFloatPoint): TArrayOfFloatPoint; overload; function Line(const X1, Y1, X2, Y2: TFloat): TArrayOfFloatPoint; overload; function VertLine(const X, Y1, Y2: TFloat): TArrayOfFloatPoint; function HorzLine(const X1, Y, X2: TFloat): TArrayOfFloatPoint; function Circle(const P: TFloatPoint; const Radius: TFloat; Steps: Integer): TArrayOfFloatPoint; overload; function Circle(const P: TFloatPoint; const Radius: TFloat): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Circle(const X, Y, Radius: TFloat; Steps: Integer): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Circle(const X, Y, Radius: TFloat): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Circle(const R: TRect): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Circle(const R: TRect; Steps: Integer): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Circle(const R: TFloatRect): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Circle(const R: TFloatRect; Steps: Integer): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Pie(const P: TFloatPoint; const Radius: TFloat; const Angle, Offset: TFloat; Steps: Integer): TArrayOfFloatPoint; overload; function Pie(const P: TFloatPoint; const Radius: TFloat; const Angle: TFloat; const Offset: TFloat = 0): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Pie(const P: TFloatPoint; const Radius: TFloat; const Angle: TFloat; Steps: Integer): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Pie(const X, Y, Radius: TFloat; const Angle, Offset: TFloat; Steps: Integer): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Pie(const X, Y, Radius: TFloat; const Angle: TFloat; const Offset: TFloat = 0): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Pie(const X, Y, Radius: TFloat; const Angle: TFloat; Steps: Integer): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Ellipse(const P, R: TFloatPoint; Steps: Integer): TArrayOfFloatPoint; overload; function Ellipse(const P, R: TFloatPoint): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Ellipse(const X, Y, Rx, Ry: TFloat; Steps: Integer): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Ellipse(const X, Y, Rx, Ry: TFloat): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Ellipse(const R: TRect): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Ellipse(const R: TFloatRect): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Ellipse(const R: TRect; Steps: Integer): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Ellipse(const R: TFloatRect; Steps: Integer): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Star(const P: TFloatPoint; const InnerRadius, OuterRadius: TFloat; Vertices: Integer = 5; Rotation: TFloat = 0): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Star(const X, Y, InnerRadius, OuterRadius: TFloat; Vertices: Integer = 5; Rotation: TFloat = 0): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Star(const P: TFloatPoint; const Radius: TFloat; Vertices: Integer = 5; Rotation: TFloat = 0): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Star(const X, Y, Radius: TFloat; Vertices: Integer = 5; Rotation: TFloat = 0): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF} function Rectangle(const R: TFloatRect): TArrayOfFloatPoint; {$IFDEF USEINLINING} inline; {$ENDIF} function RoundRect(const R: TFloatRect; const Radius: TFloat): TArrayOfFloatPoint; {$IFDEF USEINLINING} inline; {$ENDIF} function PolygonBounds(const Points: TArrayOfFloatPoint): TFloatRect; overload; function PolygonBounds(const Points: TArrayOfFixedPoint): TFixedRect; overload; function PolypolygonBounds(const Points: TArrayOfArrayOfFloatPoint): TFloatRect; overload; function PolypolygonBounds(const Points: TArrayOfArrayOfFixedPoint): TFixedRect; overload; function ScalePolygon(const Points: TArrayOfFloatPoint; ScaleX, ScaleY: TFloat): TArrayOfFloatPoint; overload; function ScalePolygon(const Points: TArrayOfFixedPoint; ScaleX, ScaleY: TFixed): TArrayOfFixedPoint; overload; function ScalePolyPolygon(const Points: TArrayOfArrayOfFloatPoint; ScaleX, ScaleY: TFloat): TArrayOfArrayOfFloatPoint; overload; function ScalePolyPolygon(const Points: TArrayOfArrayOfFixedPoint; ScaleX, ScaleY: TFixed): TArrayOfArrayOfFixedPoint; overload; procedure ScalePolygonInplace(const Points: TArrayOfFloatPoint; ScaleX, ScaleY: TFloat); overload; procedure ScalePolygonInplace(const Points: TArrayOfFixedPoint; ScaleX, ScaleY: TFixed); overload; procedure ScalePolyPolygonInplace(const Points: TArrayOfArrayOfFloatPoint; ScaleX, ScaleY: TFloat); overload; procedure ScalePolyPolygonInplace(const Points: TArrayOfArrayOfFixedPoint; ScaleX, ScaleY: TFixed); overload; function TranslatePolygon(const Points: TArrayOfFloatPoint; OffsetX, OffsetY: TFloat): TArrayOfFloatPoint; overload; function TranslatePolygon(const Points: TArrayOfFixedPoint; Offsetx, OffsetY: TFixed): TArrayOfFixedPoint; overload; function TranslatePolyPolygon(const Points: TArrayOfArrayOfFloatPoint; OffsetX, OffsetY: TFloat): TArrayOfArrayOfFloatPoint; overload; function TranslatePolyPolygon(const Points: TArrayOfArrayOfFixedPoint; OffsetX, OffsetY: TFixed): TArrayOfArrayOfFixedPoint; overload; procedure TranslatePolygonInplace(const Points: TArrayOfFloatPoint; OffsetX, OffsetY: TFloat); overload; procedure TranslatePolygonInplace(const Points: TArrayOfFixedPoint; Offsetx, OffsetY: TFixed); overload; procedure TranslatePolyPolygonInplace(const Points: TArrayOfArrayOfFloatPoint; OffsetX, OffsetY: TFloat); overload; procedure TranslatePolyPolygonInplace(const Points: TArrayOfArrayOfFixedPoint; OffsetX, OffsetY: TFixed); overload; function TransformPolygon(const Points: TArrayOfFloatPoint; Transformation: TTransformation): TArrayOfFloatPoint; overload; function TransformPolygon(const Points: TArrayOfFixedPoint; Transformation: TTransformation): TArrayOfFixedPoint; overload; function TransformPolyPolygon(const Points: TArrayOfArrayOfFloatPoint; Transformation: TTransformation): TArrayOfArrayOfFloatPoint; overload; function TransformPolyPolygon(const Points: TArrayOfArrayOfFixedPoint; Transformation: TTransformation): TArrayOfArrayOfFixedPoint; overload; function BuildPolygonF(const Data: array of TFloat): TArrayOfFloatPoint; overload; function BuildPolygonX(const Data: array of TFixed): TArrayOfFixedPoint; overload; function PolyPolygon(const Points: TArrayOfFloatPoint): TArrayOfArrayOfFloatPoint; overload; {$IFDEF USEINLINING}inline;{$ENDIF} function PolyPolygon(const Points: TArrayOfFixedPoint): TArrayOfArrayOfFixedPoint; overload; {$IFDEF USEINLINING}inline;{$ENDIF} function PointToFloatPoint(const Points: TArrayOfPoint): TArrayOfFloatPoint; overload; function PointToFloatPoint(const Points: TArrayOfArrayOfPoint): TArrayOfArrayOfFloatPoint; overload; function PointToFixedPoint(const Points: TArrayOfPoint): TArrayOfFixedPoint; overload; function PointToFixedPoint(const Points: TArrayOfArrayOfPoint): TArrayOfArrayOfFixedPoint; overload; function FixedPointToFloatPoint(const Points: TArrayOfFixedPoint): TArrayOfFloatPoint; overload; {$IFDEF USEINLINING}inline;{$ENDIF} function FixedPointToFloatPoint(const Points: TArrayOfArrayOfFixedPoint): TArrayOfArrayOfFloatPoint; overload; {$IFDEF USEINLINING}inline;{$ENDIF} function FloatPointToFixedPoint(const Points: TArrayOfFloatPoint): TArrayOfFixedPoint; overload; {$IFDEF USEINLINING}inline;{$ENDIF} function FloatPointToFixedPoint(const Points: TArrayOfArrayOfFloatPoint): TArrayOfArrayOfFixedPoint; overload; {$IFDEF USEINLINING}inline;{$ENDIF} implementation uses SysUtils, GR32_Math, GR32_Geometry, GR32_LowLevel; type TTransformationAccess = class(TTransformation); // Returns True if Min(X1, X2) <= X < Max(X1, X2) function InSignedRange(const X, X1, X2: TFloat): Boolean; begin Result := (X < X1) xor (X < X2); end; // Returns True if Min(X1, X2) <= X < Max(X1, X2) function InSignedRange(const X, X1, X2: TFixed): Boolean; begin Result := (X < X1) xor (X < X2); end; // Returns True if the intervals (X1, X2) and (Y1, Y2) overlap function OverlapExclusive(const X1, X2, Y1, Y2: TFloat): Boolean; begin Result := Abs((X1 + X2) - (Y1 + Y2)) < Abs(X1 - X2) + Abs(Y1 - Y2); end; // Returns True if the intervals (X1, X2) and (Y1, Y2) overlap function OverlapExclusive(const Pt1, Pt2: TFloatPoint): Boolean; begin Result := Abs((Pt1.X + Pt2.X) - (Pt1.Y + Pt2.Y)) < Abs(Pt1.X - Pt2.X) + Abs(Pt1.Y - Pt2.Y); end; // Returns True if the intervals (X1, X2) and (Y1, Y2) overlap function OverlapExclusive(const X1, X2, Y1, Y2: TFixed): Boolean; begin Result := Abs((X1 + X2) - (Y1 + Y2)) < Abs(X1 - X2) + Abs(Y1 - Y2); end; // Returns True if the intervals (X1, X2) and (Y1, Y2) overlap function OverlapExclusive(const Pt1, Pt2: TFixedPoint): Boolean; begin Result := Abs((Pt1.X + Pt2.X) - (Pt1.Y + Pt2.Y)) < Abs(Pt1.X - Pt2.X) + Abs(Pt1.Y - Pt2.Y); end; // Returns True if the intervals [X1, X2] and [Y1, Y2] overlap function OverlapInclusive(const X1, X2, Y1, Y2: TFloat): Boolean; begin Result := Abs((X1 + X2) - (Y1 + Y2)) <= Abs(X1 - X2) + Abs(Y1 - Y2); end; // Returns True if the intervals [X1, X2] and [Y1, Y2] overlap function OverlapInclusive(const Pt1, Pt2: TFloatPoint): Boolean; begin Result := Abs((Pt1.X + Pt2.X) - (Pt1.Y + Pt2.Y)) <= Abs(Pt1.X - Pt2.X) + Abs(Pt1.Y - Pt2.Y); end; // Returns True if the intervals [X1, X2] and [Y1, Y2] overlap function OverlapInclusive(const X1, X2, Y1, Y2: TFixed): Boolean; begin Result := Abs((X1 + X2) - (Y1 + Y2)) <= Abs(X1 - X2) + Abs(Y1 - Y2); end; // Returns True if the intervals [X1, X2] and [Y1, Y2] overlap function OverlapInclusive(const Pt1, Pt2: TFixedPoint): Boolean; begin Result := Abs((Pt1.X + Pt2.X) - (Pt1.Y + Pt2.Y)) <= Abs(Pt1.X - Pt2.X) + Abs(Pt1.Y - Pt2.Y); end; // Returns True if the line segments (A1, A2) and (B1, B2) intersects // P is the point of intersection function Intersect(const A1, A2, B1, B2: TFloatPoint; out P: TFloatPoint): Boolean; var Adx, Ady, Bdx, Bdy, ABy, ABx: TFloat; t, ta, tb: TFloat; begin Result := False; Adx := A2.X - A1.X; Ady := A2.Y - A1.Y; Bdx := B2.X - B1.X; Bdy := B2.Y - B1.Y; t := (Bdy * Adx) - (Bdx * Ady); if t = 0 then Exit; // lines are parallell ABx := A1.X - B1.X; ABy := A1.Y - B1.Y; ta := Bdx * ABy - Bdy * ABx; tb := Adx * ABy - Ady * ABx; if InSignedRange(ta, 0, t) and InSignedRange(tb, 0, t) then begin Result := True; ta := ta / t; P.X := A1.X + ta * Adx; P.Y := A1.Y + ta * Ady; end; end; function Intersect(const A1, A2, B1, B2: TFixedPoint; out P: TFixedPoint): Boolean; overload; var Adx, Ady, Bdx, Bdy, ABy, ABx: TFixed; t, ta, tb: TFixed; begin Result := False; Adx := A2.X - A1.X; Ady := A2.Y - A1.Y; Bdx := B2.X - B1.X; Bdy := B2.Y - B1.Y; t := (Bdy * Adx) - (Bdx * Ady); if t = 0 then Exit; // lines are parallell ABx := A1.X - B1.X; ABy := A1.Y - B1.Y; ta := Bdx * ABy - Bdy * ABx; tb := Adx * ABy - Ady * ABx; if InSignedRange(ta, 0, t) and InSignedRange(tb, 0, t) then begin Result := True; ta := FixedDiv(ta, t); P.X := A1.X + ta * Adx; P.Y := A1.Y + ta * Ady; end; end; function FindNearestPointIndex(Point: TFloatPoint; Points: TArrayOfFloatPoint): Integer; var Index: Integer; Distance: TFloat; NearestDistance: TFloat; begin Result := 0; NearestDistance := SqrDistance(Point, Points[0]); for Index := 1 to High(Points) do begin Distance := SqrDistance(Point, Points[Index]); if Distance < NearestDistance then begin NearestDistance := Distance; Result := Index; end; end; end; function FindNearestPointIndex(Point: TFixedPoint; Points: TArrayOfFixedPoint): Integer; var Index: Integer; Distance: TFixed; NearestDistance: TFixed; begin Result := 0; NearestDistance := SqrDistance(Point, Points[0]); for Index := 1 to High(Points) do begin Distance := SqrDistance(Point, Points[Index]); if Distance < NearestDistance then begin NearestDistance := Distance; Result := Index; end; end; end; function RamerDouglasPeucker(Points: TArrayOfFloatPoint; FirstIndex, LastIndex: Integer; Epsilon: TFloat = 1): TArrayOfFloatPoint; overload; var Index, DeltaMaxIndex: Integer; Delta, DeltaMax: TFloat; Parts: array [0 .. 1] of TArrayOfFloatPoint; begin if LastIndex - FirstIndex > 1 then begin // find the point with the maximum distance DeltaMax := 0; DeltaMaxIndex := 0; for Index := FirstIndex + 1 to LastIndex - 1 do begin with Points[LastIndex] do Delta := Abs((Points[Index].x - x) * (Points[FirstIndex].y - y) - (Points[Index].y - y) * (Points[FirstIndex].x - x)); if Delta > DeltaMax then begin DeltaMaxIndex := Index; DeltaMax := Delta; end; end; // if max distance is greater than epsilon, recursively simplify if DeltaMax >= Epsilon * GR32_Math.Hypot(Points[FirstIndex].x - Points[LastIndex].x, Points[FirstIndex].y - Points[LastIndex].y) then begin // Recursive call Parts[0] := RamerDouglasPeucker(Points, FirstIndex, DeltaMaxIndex, Epsilon); Parts[1] := RamerDouglasPeucker(Points, DeltaMaxIndex, LastIndex, Epsilon); // Build the result list SetLength(Result, Length(Parts[0]) + Length(Parts[1]) - 1); Move(Parts[0, 0], Result[0], (Length(Parts[0]) - 1) * SizeOf(TFloatPoint)); Move(Parts[1, 0], Result[Length(Parts[0]) - 1], Length(Parts[1]) * SizeOf(TFloatPoint)); Exit; end; end; SetLength(Result, 2); Result[0] := Points[FirstIndex]; Result[1] := Points[LastIndex]; end; function RamerDouglasPeucker(Points: TArrayOfFixedPoint; FirstIndex, LastIndex: Integer; Epsilon: TFixed = 1): TArrayOfFixedPoint; overload; var Index, DeltaMaxIndex: Integer; Delta, DeltaMax: TFixed; Parts: array [0 .. 1] of TArrayOfFixedPoint; //Finds the perpendicular distance from a point to a straight line. //The coordinates of the point are specified as $ptX and $ptY. //The line passes through points l1 and l2, specified respectively with their //coordinates $l1x and $l1y, and $l2x and $l2y function PerpendicularDistance(ptX, ptY, l1x, l1y, l2x, l2y: TFixed): TFixed; var Slope, PassThroughY: TFixed; begin if (l2x = l1x) then begin //vertical lines - treat this case specially to avoid divide by zero Result := Abs(ptX - l2x); end else begin Slope := FixedDiv(l2y-l1y, l2x-l1x); PassThroughY := FixedMul(0 - l1x, Slope) + l1y; Result := FixedDiv(Abs(FixedMul(Slope, ptX) - ptY + PassThroughY), FixedSqrtHP(FixedSqr(Slope) + 1)); end; end; begin if LastIndex - FirstIndex > 1 then begin // find the point with the maximum distance DeltaMax := 0; DeltaMaxIndex := 0; for Index := FirstIndex + 1 to LastIndex - 1 do begin Delta := PerpendicularDistance( Points[Index].x, Points[Index].y, Points[FirstIndex].x, Points[FirstIndex].y, Points[LastIndex].x, Points[LastIndex].y); if Delta > DeltaMax then begin DeltaMaxIndex := Index; DeltaMax := Delta; end; end; // if max distance is greater than epsilon, recursively simplify if DeltaMax > Epsilon then begin // Recursive call Parts[0] := RamerDouglasPeucker(Points, FirstIndex, DeltaMaxIndex, Epsilon); Parts[1] := RamerDouglasPeucker(Points, DeltaMaxIndex, LastIndex, Epsilon); // Build the result list SetLength(Result, Length(Parts[0]) + Length(Parts[1]) - 1); Move(Parts[0, 0], Result[0], (Length(Parts[0]) - 1) * SizeOf(TFixedPoint)); Move(Parts[1, 0], Result[Length(Parts[0]) - 1], Length(Parts[1]) * SizeOf(TFixedPoint)); Exit; end; end; SetLength(Result, 2); Result[0] := Points[FirstIndex]; Result[1] := Points[LastIndex]; end; function VertexReduction(Points: TArrayOfFloatPoint; Epsilon: TFloat = 1): TArrayOfFloatPoint; var Index: Integer; SqrEpsilon: TFloat; begin SqrEpsilon := Sqr(Epsilon); SetLength(Result, 1); Result[0] := Points[0]; Index := 1; while Index < Length(Points) do begin if SqrDistance(Result[Length(Result) - 1], Points[Index]) > SqrEpsilon then begin SetLength(Result, Length(Result) + 1); Result[Length(Result) - 1] := Points[Index]; end; Inc(Index); end; if Length(Result) > 2 then Result := RamerDouglasPeucker(Result, 0, Length(Result) - 1, Epsilon); end; function VertexReduction(Points: TArrayOfFixedPoint; Epsilon: TFixed): TArrayOfFixedPoint; var Index: Integer; SqrEpsilon: TFixed; begin SqrEpsilon := FixedSqr(Epsilon); SetLength(Result, 1); Result[0] := Points[0]; Index := 1; while Index < Length(Points) do begin if SqrDistance(Result[Length(Result) - 1], Points[Index]) > SqrEpsilon then begin SetLength(Result, Length(Result) + 1); Result[Length(Result) - 1] := Points[Index]; end; Inc(Index); end; Result := RamerDouglasPeucker(Points, 0, Length(Points) - 1, Epsilon); end; function ClosePolygon(const Points: TArrayOfFloatPoint): TArrayOfFloatPoint; var L: Integer; P1, P2: TFloatPoint; begin L := Length(Points); Result := Points; if L <= 1 then Exit; P1 := Result[0]; P2 := Result[L - 1]; if (P1.X = P2.X) and (P1.Y = P2.Y) then Exit; SetLength(Result, L + 1); Move(Result[0], Points[0], L * SizeOf(TFloatPoint)); Result[L] := P1; end; function ClosePolygon(const Points: TArrayOfFixedPoint): TArrayOfFixedPoint; var L: Integer; P1, P2: TFixedPoint; begin L := Length(Points); Result := Points; if L <= 1 then Exit; P1 := Result[0]; P2 := Result[L - 1]; if (P1.X = P2.X) and (P1.Y = P2.Y) then Exit; SetLength(Result, L + 1); Move(Result[0], Points[0], L * SizeOf(TFixedPoint)); Result[L] := P1; end; function ClipLine(var X1, Y1, X2, Y2: Integer; MinX, MinY, MaxX, MaxY: Integer): Boolean; var C1, C2: Integer; V: Integer; begin { Get edge codes } C1 := Ord(X1 < MinX) + Ord(X1 > MaxX) shl 1 + Ord(Y1 < MinY) shl 2 + Ord(Y1 > MaxY) shl 3; C2 := Ord(X2 < MinX) + Ord(X2 > MaxX) shl 1 + Ord(Y2 < MinY) shl 2 + Ord(Y2 > MaxY) shl 3; if ((C1 and C2) = 0) and ((C1 or C2) <> 0) then begin if (C1 and 12) <> 0 then begin if C1 < 8 then V := MinY else V := MaxY; Inc(X1, MulDiv(V - Y1, X2 - X1, Y2 - Y1)); Y1 := V; C1 := Ord(X1 < MinX) + Ord(X1 > MaxX) shl 1; end; if (C2 and 12) <> 0 then begin if C2 < 8 then V := MinY else V := MaxY; Inc(X2, MulDiv(V - Y2, X2 - X1, Y2 - Y1)); Y2 := V; C2 := Ord(X2 < MinX) + Ord(X2 > MaxX) shl 1; end; if ((C1 and C2) = 0) and ((C1 or C2) <> 0) then begin if C1 <> 0 then begin if C1 = 1 then V := MinX else V := MaxX; Inc(Y1, MulDiv(V - X1, Y2 - Y1, X2 - X1)); X1 := V; C1 := 0; end; if C2 <> 0 then begin if C2 = 1 then V := MinX else V := MaxX; Inc(Y2, MulDiv(V - X2, Y2 - Y1, X2 - X1)); X2 := V; C2 := 0; end; end; end; Result := (C1 or C2) = 0; end; function ClipLine(var X1, Y1, X2, Y2: TFloat; MinX, MinY, MaxX, MaxY: TFloat): Boolean; var C1, C2: Integer; V: TFloat; begin { Get edge codes } C1 := Ord(X1 < MinX) + Ord(X1 > MaxX) shl 1 + Ord(Y1 < MinY) shl 2 + Ord(Y1 > MaxY) shl 3; C2 := Ord(X2 < MinX) + Ord(X2 > MaxX) shl 1 + Ord(Y2 < MinY) shl 2 + Ord(Y2 > MaxY) shl 3; if ((C1 and C2) = 0) and ((C1 or C2) <> 0) then begin if (C1 and 12) <> 0 then begin if C1 < 8 then V := MinY else V := MaxY; X1 := X1 + (V - Y1) * (X2 - X1) / (Y2 - Y1); Y1 := V; C1 := Ord(X1 < MinX) + Ord(X1 > MaxX) shl 1; end; if (C2 and 12) <> 0 then begin if C2 < 8 then V := MinY else V := MaxY; X2 := X2 + (V - Y2) * (X2 - X1) / (Y2 - Y1); Y2 := V; C2 := Ord(X2 < MinX) + Ord(X2 > MaxX) shl 1; end; if ((C1 and C2) = 0) and ((C1 or C2) <> 0) then begin if C1 <> 0 then begin if C1 = 1 then V := MinX else V := MaxX; Y1 := Y1 + (V - X1) * (Y2 - Y1) / (X2 - X1); X1 := V; C1 := 0; end; if C2 <> 0 then begin if C2 = 1 then V := MinX else V := MaxX; Y2 := Y2 + (V - X2) * (Y2 - Y1) / (X2 - X1); X2 := V; C2 := 0; end; end; end; Result := (C1 or C2) = 0; end; function ClipLine(var X1, Y1, X2, Y2: TFixed; MinX, MinY, MaxX, MaxY: TFixed): Boolean; var C1, C2: Integer; V: TFixed; begin { Get edge codes } C1 := Ord(X1 < MinX) + Ord(X1 > MaxX) shl 1 + Ord(Y1 < MinY) shl 2 + Ord(Y1 > MaxY) shl 3; C2 := Ord(X2 < MinX) + Ord(X2 > MaxX) shl 1 + Ord(Y2 < MinY) shl 2 + Ord(Y2 > MaxY) shl 3; if ((C1 and C2) = 0) and ((C1 or C2) <> 0) then begin if (C1 and 12) <> 0 then begin if C1 < 8 then V := MinY else V := MaxY; X1 := X1 + FixedDiv(FixedMul(V - Y1, X2 - X1), Y2 - Y1); Y1 := V; C1 := Ord(X1 < MinX) + Ord(X1 > MaxX) shl 1; end; if (C2 and 12) <> 0 then begin if C2 < 8 then V := MinY else V := MaxY; X2 := X2 + FixedDiv(FixedMul(V - Y2, X2 - X1), Y2 - Y1); Y2 := V; C2 := Ord(X2 < MinX) + Ord(X2 > MaxX) shl 1; end; if ((C1 and C2) = 0) and ((C1 or C2) <> 0) then begin if C1 <> 0 then begin if C1 = 1 then V := MinX else V := MaxX; Y1 := Y1 + FixedDiv(FixedMul(V - X1, Y2 - Y1), X2 - X1); X1 := V; C1 := 0; end; if C2 <> 0 then begin if C2 = 1 then V := MinX else V := MaxX; Y2 := Y2 + FixedDiv(FixedMul(V - X2, Y2 - Y1), X2 - X1); X2 := V; C2 := 0; end; end; end; Result := (C1 or C2) = 0; end; function ClipLine(var P1, P2: TPoint; const ClipRect: TRect): Boolean; begin Result := ClipLine(P1.X, P1.Y, P2.X, P2.Y, ClipRect.Left, ClipRect.Top, ClipRect.Right, ClipRect.Bottom); end; function ClipLine(var P1, P2: TFloatPoint; const ClipRect: TFloatRect): Boolean; begin Result := ClipLine(P1.X, P1.Y, P2.X, P2.Y, ClipRect.Left, ClipRect.Top, ClipRect.Right, ClipRect.Bottom); end; function ClipLine(var P1, P2: TFixedPoint; const ClipRect: TFixedRect): Boolean; begin Result := ClipLine(P1.X, P1.Y, P2.X, P2.Y, ClipRect.Left, ClipRect.Top, ClipRect.Right, ClipRect.Bottom); end; procedure Extract(Src: TArrayOfFloat; Indexes: TArrayOfInteger; out Dst: TArrayOfFloat); var I: Integer; begin SetLength(Dst, Length(Indexes)); for I := 0 to High(Indexes) do Dst[I] := Src[Indexes[I]]; end; procedure Extract(Src: TArrayOfFixed; Indexes: TArrayOfInteger; out Dst: TArrayOfFixed); var I: Integer; begin SetLength(Dst, Length(Indexes)); for I := 0 to High(Indexes) do Dst[I] := Src[Indexes[I]]; end; // A modified implementation of merge sort // - returns the indexes of the sorted elements // - use Extract(Indexes, Output) to return the sorted values // - complexity when input is already sorted: O(n) // - worst case complexity: O(n log n) procedure FastMergeSort(const Values: TArrayOfFloat; out Indexes: TArrayOfInteger); var Temp: TArrayOfInteger; procedure Merge(I1, I2, J1, J2: Integer); var I, J, K: Integer; begin if Values[Indexes[I2]] < Values[Indexes[J1]] then Exit; I := I1; J := J1; K := 0; repeat if Values[Indexes[I]] < Values[Indexes[J]] then begin Temp[K] := Indexes[I]; Inc(I); end else begin Temp[K] := Indexes[J]; Inc(J); end; Inc(K); until (I > I2) or (J > J2); while I <= I2 do begin Temp[K] := Indexes[I]; Inc(I); Inc(K); end; while J <= J2 do begin Temp[K] := Indexes[J]; Inc(J); Inc(K); end; for I := 0 to K - 1 do begin Indexes[I + I1] := Temp[I]; end; end; procedure Recurse(I1, I2: Integer); var I, IX: Integer; begin if I1 = I2 then Indexes[I1] := I1 else if Indexes[I1] = Indexes[I2] then begin if Values[I1] <= Values[I2] then begin for I := I1 to I2 do Indexes[I] := I; end else begin IX := I1 + I2; for I := I1 to I2 do Indexes[I] := IX - I; end; end else begin IX := (I1 + I2) div 2; Recurse(I1, IX); Recurse(IX + 1, I2); Merge(I1, IX, IX + 1, I2); end; end; var I, Index, S: Integer; begin SetLength(Temp, Length(Values)); SetLength(Indexes, Length(Values)); Index := 0; S := Math.Sign(Values[1] - Values[0]); if S = 0 then S := 1; Indexes[0] := 0; for I := 1 to High(Values) do begin if Math.Sign(Values[I] - Values[I - 1]) = -S then begin S := -S; Inc(Index); end; Indexes[I] := Index; end; Recurse(0, High(Values)); end; // A modified implementation of merge sort // - returns the indexes of the sorted elements // - use Extract(Indexes, Output) to return the sorted values // - complexity when input is already sorted: O(n) // - worst case complexity: O(n log n) procedure FastMergeSort(const Values: TArrayOfFixed; out Indexes: TArrayOfInteger); var Temp: TArrayOfInteger; procedure Merge(I1, I2, J1, J2: Integer); var I, J, K: Integer; begin if Values[Indexes[I2]] < Values[Indexes[J1]] then Exit; I := I1; J := J1; K := 0; repeat if Values[Indexes[I]] < Values[Indexes[J]] then begin Temp[K] := Indexes[I]; Inc(I); end else begin Temp[K] := Indexes[J]; Inc(J); end; Inc(K); until (I > I2) or (J > J2); while I <= I2 do begin Temp[K] := Indexes[I]; Inc(I); Inc(K); end; while J <= J2 do begin Temp[K] := Indexes[J]; Inc(J); Inc(K); end; for I := 0 to K - 1 do begin Indexes[I + I1] := Temp[I]; end; end; procedure Recurse(I1, I2: Integer); var I, IX: Integer; begin if I1 = I2 then Indexes[I1] := I1 else if Indexes[I1] = Indexes[I2] then begin if Values[I1] <= Values[I2] then begin for I := I1 to I2 do Indexes[I] := I; end else begin IX := I1 + I2; for I := I1 to I2 do Indexes[I] := IX - I; end; end else begin IX := (I1 + I2) div 2; Recurse(I1, IX); Recurse(IX + 1, I2); Merge(I1, IX, IX + 1, I2); end; end; var I, Index, S: Integer; begin SetLength(Temp, Length(Values)); SetLength(Indexes, Length(Values)); Index := 0; S := Math.Sign(Values[1] - Values[0]); if S = 0 then S := 1; Indexes[0] := 0; for I := 1 to High(Values) do begin if Math.Sign(Values[I] - Values[I - 1]) = -S then begin S := -S; Inc(Index); end; Indexes[I] := Index; end; Recurse(0, High(Values)); end; procedure FastMergeSortX(const Values: TArrayOfFloatPoint; out Indexes: TArrayOfInteger; out Bounds: TFloatRect); var Temp: TArrayOfInteger; procedure Merge(I1, I2, J1, J2: Integer); var I, J, K: Integer; begin if Values[Indexes[I2]].X < Values[Indexes[J1]].X then Exit; I := I1; J := J1; K := 0; repeat if Values[Indexes[I]].X < Values[Indexes[J]].X then begin Temp[K] := Indexes[I]; Inc(I); end else begin Temp[K] := Indexes[J]; Inc(J); end; Inc(K); until (I > I2) or (J > J2); while I <= I2 do begin Temp[K] := Indexes[I]; Inc(I); Inc(K); end; while J <= J2 do begin Temp[K] := Indexes[J]; Inc(J); Inc(K); end; for I := 0 to K - 1 do begin Indexes[I + I1] := Temp[I]; end; end; procedure Recurse(I1, I2: Integer); var I, IX: Integer; begin if I1 = I2 then Indexes[I1] := I1 else if Indexes[I1] = Indexes[I2] then begin if Values[I1].X <= Values[I2].X then begin for I := I1 to I2 do Indexes[I] := I; end else begin IX := I1 + I2; for I := I1 to I2 do Indexes[I] := IX - I; end; end else begin IX := (I1 + I2) div 2; Recurse(I1, IX); Recurse(IX + 1, I2); Merge(I1, IX, IX + 1, I2); end; end; var I, Index, S: Integer; begin SetLength(Temp, Length(Values)); SetLength(Indexes, Length(Values)); Index := 0; S := Math.Sign(Values[1].X - Values[0].X); if S = 0 then S := 1; Indexes[0] := 0; Bounds.Left := Values[0].X; Bounds.Top := Values[0].Y; Bounds.Right := Bounds.Left; Bounds.Bottom := Bounds.Top; for I := 1 to High(Values) do begin if Math.Sign(Values[I].X - Values[I - 1].X) = -S then begin S := -S; Inc(Index); end; if Values[I].X < Bounds.Left then Bounds.Left := Values[I].X; if Values[I].Y < Bounds.Top then Bounds.Top := Values[I].Y; if Values[I].X > Bounds.Right then Bounds.Right := Values[I].X; if Values[I].Y > Bounds.Bottom then Bounds.Bottom := Values[I].Y; Indexes[I] := Index; end; Recurse(0, High(Values)); end; function DelaunayTriangulation(Points: TArrayOfFloatPoint): TArrayOfTriangleVertexIndices; var Complete: array of Byte; Edges: array of array [0 .. 1] of Integer; ByteIndex, Bit: Byte; MaxVerticesCount, EdgeCount, MaxEdgeCount, MaxTriangleCount: Integer; // For super triangle ScaledDeltaMax: TFloat; Mid: TFloatPoint; Bounds: TFloatRect; // General Variables SortedVertexIndices: TArrayOfInteger; TriangleCount, VertexCount, I, J, K: Integer; CenterX, CenterY, RadSqr: TFloat; Inside: Boolean; const CSuperTriangleCount = 3; // -> super triangle CTolerance = 0.000001; function InCircle(Pt, Pt1, Pt2, Pt3: TFloatPoint): Boolean; // Return TRUE if the point Pt(x, y) lies inside the circumcircle made up by // points Pt1(x, y) Pt2(x, y) Pt3(x, y) // The circumcircle centre is returned in (CenterX, CenterY) and the radius r // NOTE: A point on the edge is inside the circumcircle var M1, M2, MX1, MY1, MX2, MY2: Double; DeltaX, DeltaY, DeltaRadSqr, AbsY1Y2, AbsY2Y3: Double; begin AbsY1Y2 := Abs(Pt1.Y - Pt2.Y); AbsY2Y3 := Abs(Pt2.Y - Pt3.Y); // Check for coincident points if (AbsY1Y2 < CTolerance) and (AbsY2Y3 < CTolerance) then begin Result := False; Exit; end; if AbsY1Y2 < CTolerance then begin M2 := -(Pt3.X - Pt2.X) / (Pt3.Y - Pt2.Y); MX2 := (Pt2.X + Pt3.X) * 0.5; MY2 := (Pt2.Y + Pt3.Y) * 0.5; CenterX := (Pt2.X + Pt1.X) * 0.5; CenterY := M2 * (CenterX - MX2) + MY2; end else if AbsY2Y3 < CTolerance then begin M1 := -(Pt2.X - Pt1.X) / (Pt2.Y - Pt1.Y); MX1 := (Pt1.X + Pt2.X) * 0.5; MY1 := (Pt1.Y + Pt2.Y) * 0.5; CenterX := (Pt3.X + Pt2.X) * 0.5; CenterY := M1 * (CenterX - MX1) + MY1; end else begin M1 := -(Pt2.X - Pt1.X) / (Pt2.Y - Pt1.Y); M2 := -(Pt3.X - Pt2.X) / (Pt3.Y - Pt2.Y); MX1 := (Pt1.X + Pt2.X) * 0.5; MX2 := (Pt2.X + Pt3.X) * 0.5; MY1 := (Pt1.Y + Pt2.Y) * 0.5; MY2 := (Pt2.Y + Pt3.Y) * 0.5; CenterX := (M1 * MX1 - M2 * Mx2 + My2 - MY1) / (M1 - M2); if (AbsY1Y2 > AbsY2Y3) then CenterY := M1 * (CenterX - MX1) + MY1 else CenterY := M2 * (CenterX - MX2) + MY2; end; DeltaX := Pt2.X - CenterX; DeltaY := Pt2.Y - CenterY; RadSqr := DeltaX * DeltaX + DeltaY * DeltaY; DeltaX := Pt.X - CenterX; DeltaY := Pt.Y - CenterY; DeltaRadSqr := Sqr(DeltaX) + Sqr(DeltaY); Result := (DeltaRadSqr - RadSqr) <= CTolerance; end; begin VertexCount := Length(Points); MaxVerticesCount := VertexCount + CSuperTriangleCount; // Sort points by x value and find maximum and minimum vertex bounds. FastMergeSortX(Points, SortedVertexIndices, Bounds); // set dynamic array sizes SetLength(Points, MaxVerticesCount); MaxTriangleCount := 2 * (MaxVerticesCount - 1); SetLength(Result, MaxTriangleCount); MaxEdgeCount := 3 * (MaxVerticesCount - 1); SetLength(Edges, MaxEdgeCount); SetLength(Complete, (MaxTriangleCount + 7) shr 3); // This is to allow calculation of the bounding triangle with Bounds do begin ScaledDeltaMax := 30 * Max(Right - Left, Bottom - Top); Mid := FloatPoint((Left + Right) * 0.5, (Top + Bottom) * 0.5); end; // Set up the super triangle // This is a triangle which encompasses all the sample points. The super // triangle coordinates are added to the end of the vertex list. The super // triangle is the first triangle in the triangle list. Points[VertexCount] := FloatPoint(Mid.X - ScaledDeltaMax, Mid.Y - ScaledDeltaMax); Points[VertexCount + 1] := FloatPoint(Mid.X + ScaledDeltaMax, Mid.Y); Points[VertexCount + 2] := FloatPoint(Mid.X, Mid.Y + ScaledDeltaMax); Result[0, 0] := VertexCount; Result[0, 1] := VertexCount + 1; Result[0, 2] := VertexCount + 2; Complete[0] := 0; TriangleCount := 1; // Include each point one at a time into the existing mesh for I := 0 to VertexCount - 1 do begin EdgeCount := 0; // Set up the edge buffer. // If the point [x, y] lies inside the circumcircle then the hree edges of // that triangle are added to the edge buffer. J := 0; repeat if Complete[J shr 3] and (1 shl (J and $7)) = 0 then begin Inside := InCircle(Points[SortedVertexIndices[I]], Points[Result[J, 0]], Points[Result[J, 1]], Points[Result[J, 2]]); ByteIndex := J shr 3; Bit := 1 shl (J and $7); if (CenterX < Points[SortedVertexIndices[I]].X) and ((Sqr(Points[SortedVertexIndices[I]].X - CenterX)) > RadSqr) then Complete[ByteIndex] := Complete[ByteIndex] or Bit else if Inside then begin Edges[EdgeCount + 0, 0] := Result[J, 0]; Edges[EdgeCount + 0, 1] := Result[J, 1]; Edges[EdgeCount + 1, 0] := Result[J, 1]; Edges[EdgeCount + 1, 1] := Result[J, 2]; Edges[EdgeCount + 2, 0] := Result[J, 2]; Edges[EdgeCount + 2, 1] := Result[J, 0]; EdgeCount := EdgeCount + 3; Assert(EdgeCount <= MaxEdgeCount); TriangleCount := TriangleCount - 1; Result[J] := Result[TriangleCount]; Complete[ByteIndex] := (Complete[ByteIndex] and (not Bit)) or (Complete[TriangleCount shr 3] and Bit); Continue; end; end; J := J + 1; until J >= TriangleCount; // Tag multiple edges // Note: if all triangles are specified anticlockwise then all // interior edges are opposite pointing in direction. for J := 0 to EdgeCount - 2 do begin if (Edges[J, 0] <> -1) or (Edges[J, 1] <> -1) then begin for K := J + 1 to EdgeCount - 1 do begin if (Edges[K, 0] <> -1) or (Edges[K, 1] <> -1) then begin if (Edges[J, 0] = Edges[K, 1]) and (Edges[J, 1] = Edges[K, 0]) then begin Edges[J, 0] := -1; Edges[J, 1] := -1; Edges[K, 1] := -1; Edges[K, 0] := -1; end; end; end; end; end; // Form new triangles for the current point. // Skipping over any tagged edges. All edges are arranged in clockwise // order. for J := 0 to EdgeCount - 1 do begin if (Edges[J, 0] <> -1) or (Edges[J, 1] <> -1) then begin Result[TriangleCount, 0] := Edges[J, 0]; Result[TriangleCount, 1] := Edges[J, 1]; Result[TriangleCount, 2] := SortedVertexIndices[I]; ByteIndex := TriangleCount shr 3; Bit := 1 shl (TriangleCount and $7); Complete[ByteIndex] := Complete[ByteIndex] and not Bit; Inc(TriangleCount); Assert(TriangleCount <= MaxTriangleCount); end; end; end; // Remove triangles with supertriangle vertices // These are triangles which have a vertex number greater than VertexCount I := 0; repeat if (Result[I, 0] >= VertexCount) or (Result[I, 1] >= VertexCount) or (Result[I, 2] >= VertexCount) then begin TriangleCount := TriangleCount - 1; Result[I, 0] := Result[TriangleCount, 0]; Result[I, 1] := Result[TriangleCount, 1]; Result[I, 2] := Result[TriangleCount, 2]; I := I - 1; end; I := I + 1; until I >= TriangleCount; SetLength(Points, Length(Points) - 3); SetLength(Result, TriangleCount); end; function BuildArc(const P: TFloatPoint; StartAngle, EndAngle, Radius: TFloat; Steps: Integer): TArrayOfFloatPoint; var I: Integer; C, D: TFloatPoint; begin SetLength(Result, Steps); SinCos(StartAngle, Radius, C.Y, C.X); Result[0] := OffsetPoint(P, C); GR32_Math.SinCos((EndAngle - StartAngle) / (Steps - 1), D.Y, D.X); for I := 1 to Steps - 1 do begin C := FloatPoint(C.X * D.X - C.Y * D.Y, C.Y * D.X + C.X * D.Y); Result[I] := OffsetPoint(P, C); end; end; function BuildArc(const P: TFloatPoint; StartAngle, EndAngle, Radius: TFloat): TArrayOfFloatPoint; const MINSTEPS = 6; SQUAREDMINSTEPS = Sqr(MINSTEPS); var Temp: TFloat; Steps: Integer; begin // The code below was previously: // // Steps := Max(MINSTEPS, System.Round(Sqrt(Abs(Radius)) * // Abs(EndAngle - StartAngle))); // // However, for small radii, the square root calculation is performed with // the result that the output is set to 6 anyway. In this case (only a few // drawing operations), the performance spend for this calculation is dominant // for large radii (when a lot of CPU intensive drawing takes place), the // more expensive float point comparison (Temp < SQUAREDMINSTEPS) is not very // significant Temp := Abs(Radius) * Sqr(EndAngle - StartAngle); if Temp < SQUAREDMINSTEPS then Steps := 6 else Steps := Round(Sqrt(Temp)); Result := BuildArc(P, StartAngle, EndAngle, Radius, Steps); end; function BuildArc(const P: TFixedPoint; StartAngle, EndAngle, Radius: TFloat; Steps: Integer): TArrayOfFixedPoint; var I: Integer; C, D: TFloatPoint; begin SetLength(Result, Steps); SinCos(StartAngle, Radius, C.Y, C.X); Result[0] := OffsetPoint(P, C); GR32_Math.SinCos((EndAngle - StartAngle) / (Steps - 1), D.Y, D.X); for I := 1 to Steps - 1 do begin C := FloatPoint(C.X * D.X - C.Y * D.Y, C.Y * D.X + C.X * D.Y); Result[I] := OffsetPoint(P, FixedPoint(C)); end; end; function BuildArc(const P: TFixedPoint; StartAngle, EndAngle, Radius: TFloat): TArrayOfFixedPoint; const MINSTEPS = 6; SQUAREDMINSTEPS = Sqr(MINSTEPS); var Temp: TFloat; Steps: Integer; begin // The code below was previously: // // Steps := Clamp(System.Round(Sqrt(Abs(Radius)) * // Abs(EndAngle - StartAngle)), MINSTEPS, $100000); // // However, for small radii, the square root calculation is performed with // the result that the output is set to 6 anyway. In this case (only a few // drawing operations), the performance spend for this calculation is dominant // for large radii (when a lot of CPU intensive drawing takes place), the // more expensive float point comparison (Temp < SQUAREDMINSTEPS) is not very // significant Temp := Abs(Radius) * Sqr(EndAngle - StartAngle); if Temp < SQUAREDMINSTEPS then Steps := MINSTEPS else Steps := Clamp(Round(Sqrt(Temp)), $100000); Result := BuildArc(P, StartAngle, EndAngle, Radius, Steps); end; function Line(const P1, P2: TFloatPoint): TArrayOfFloatPoint; begin SetLength(Result, 2); Result[0] := P1; Result[1] := P2; end; function Line(const X1, Y1, X2, Y2: TFloat): TArrayOfFloatPoint; overload; begin SetLength(Result, 2); Result[0] := FloatPoint(X1, Y1); Result[1] := FloatPoint(X2, Y2); end; function VertLine(const X, Y1, Y2: TFloat): TArrayOfFloatPoint; begin SetLength(Result, 2); Result[0] := FloatPoint(X, Y1); Result[1] := FloatPoint(X, Y2); end; function HorzLine(const X1, Y, X2: TFloat): TArrayOfFloatPoint; begin SetLength(Result, 2); Result[0] := FloatPoint(X1, Y); Result[1] := FloatPoint(X2, Y); end; function CalculateCircleSteps(Radius: TFloat): Cardinal; var AbsRadius: TFloat; begin AbsRadius := Abs(Radius); Result := Trunc(Pi / (ArcCos(AbsRadius / (AbsRadius + 0.125)))); end; function Circle(const P: TFloatPoint; const Radius: TFloat; Steps: Integer): TArrayOfFloatPoint; var I: Integer; M: TFloat; C, D: TFloatPoint; begin if Steps <= 0 then Steps := CalculateCircleSteps(Radius); SetLength(Result, Steps); M := 2 * System.Pi / Steps; // first item Result[0].X := Radius + P.X; Result[0].Y := P.Y; // calculate complex offset GR32_Math.SinCos(M, C.Y, C.X); D.X := Radius * C.X; D.Y := Radius * C.Y; // second item Result[1].X := D.X + P.X; Result[1].Y := D.Y + P.Y; // other items for I := 2 to Steps - 1 do begin D := FloatPoint(D.X * C.X - D.Y * C.Y, D.Y * C.X + D.X * C.Y); Result[I].X := D.X + P.X; Result[I].Y := D.Y + P.Y; end; end; function Circle(const P: TFloatPoint; const Radius: TFloat): TArrayOfFloatPoint; begin Result := Circle(P, Radius, CalculateCircleSteps(Radius)); end; function Circle(const X, Y, Radius: TFloat; Steps: Integer): TArrayOfFloatPoint; begin Result := Circle(FloatPoint(X, Y), Radius, Steps); end; function Circle(const X, Y, Radius: TFloat): TArrayOfFloatPoint; begin Result := Circle(FloatPoint(X, Y), Radius, CalculateCircleSteps(Radius)); end; function Circle(const R: TRect): TArrayOfFloatPoint; begin Result := Circle( FloatPoint(0.5 * (R.Right + R.Left), 0.5 * (R.Bottom + R.Top)), Min(0.5 * (R.Right - R.Left), 0.5 * (R.Bottom - R.Top))); end; function Circle(const R: TRect; Steps: Integer): TArrayOfFloatPoint; begin Result := Circle( FloatPoint(0.5 * (R.Right + R.Left), 0.5 * (R.Bottom + R.Top)), Min(0.5 * (R.Right - R.Left), 0.5 * (R.Bottom - R.Top)), Steps); end; function Circle(const R: TFloatRect): TArrayOfFloatPoint; begin Result := Circle( FloatPoint(0.5 * (R.Right + R.Left), 0.5 * (R.Bottom + R.Top)), Min(0.5 * (R.Right - R.Left), 0.5 * (R.Bottom - R.Top))); end; function Circle(const R: TFloatRect; Steps: Integer): TArrayOfFloatPoint; begin Result := Circle( FloatPoint(0.5 * (R.Right + R.Left), 0.5 * (R.Bottom + R.Top)), Min(0.5 * (R.Right - R.Left), 0.5 * (R.Bottom - R.Top)), Steps); end; function Pie(const P: TFloatPoint; const Radius: TFloat; const Angle, Offset: TFloat; Steps: Integer): TArrayOfFloatPoint; var I: Integer; C, D: TFloatPoint; begin SetLength(Result, Steps + 2); Result[0] := P; // calculate initial position GR32_Math.SinCos(Offset, Radius, D.Y, D.X); Result[1].X := D.X + P.X; Result[1].Y := D.Y + P.Y; // calculate complex offset GR32_Math.SinCos(Angle / Steps, C.Y, C.X); // other items for I := 2 to Steps + 1 do begin D := FloatPoint(D.X * C.X - D.Y * C.Y, D.Y * C.X + D.X * C.Y); Result[I].X := D.X + P.X; Result[I].Y := D.Y + P.Y; end; end; function Pie(const P: TFloatPoint; const Radius: TFloat; const Angle: TFloat; const Offset: TFloat = 0): TArrayOfFloatPoint; begin Result := Pie(P, Radius, Angle, Offset, CalculateCircleSteps(Radius)); end; function Pie(const P: TFloatPoint; const Radius: TFloat; const Angle: TFloat; Steps: Integer): TArrayOfFloatPoint; begin Result := Pie(P, Radius, Angle, 0, Steps); end; function Pie(const X, Y, Radius: TFloat; const Angle: TFloat; const Offset: TFloat = 0): TArrayOfFloatPoint; begin Result := Pie(FloatPoint(X, Y), Radius, Angle, Offset, CalculateCircleSteps(Radius)); end; function Pie(const X, Y, Radius: TFloat; const Angle, Offset: TFloat; Steps: Integer): TArrayOfFloatPoint; begin Result := Pie(FloatPoint(X, Y), Radius, Angle, Offset, Steps); end; function Pie(const X, Y, Radius: TFloat; const Angle: TFloat; Steps: Integer): TArrayOfFloatPoint; begin Result := Pie(FloatPoint(X, Y), Radius, Angle, 0, Steps); end; function Ellipse(const P, R: TFloatPoint; Steps: Integer): TArrayOfFloatPoint; var I: Integer; M: TFloat; C, D: TFloatPoint; begin SetLength(Result, Steps); M := 2 * System.Pi / Steps; // first item Result[0].X := R.X + P.X; Result[0].Y := P.Y; // calculate complex offset GR32_Math.SinCos(M, C.Y, C.X); D := C; // second item Result[1].X := R.X * D.X + P.X; Result[1].Y := R.Y * D.Y + P.Y; // other items for I := 2 to Steps - 1 do begin D := FloatPoint(D.X * C.X - D.Y * C.Y, D.Y * C.X + D.X * C.Y); Result[I].X := R.X * D.X + P.X; Result[I].Y := R.Y * D.Y + P.Y; end; end; function Ellipse(const P, R: TFloatPoint): TArrayOfFloatPoint; begin Result := Ellipse(P, R, CalculateCircleSteps(Min(R.X, R.Y))); end; function Ellipse(const X, Y, Rx, Ry: TFloat; Steps: Integer): TArrayOfFloatPoint; begin Result := Ellipse(FloatPoint(X, Y), FloatPoint(Rx, Ry), Steps); end; function Ellipse(const X, Y, Rx, Ry: TFloat): TArrayOfFloatPoint; begin Result := Ellipse(FloatPoint(X, Y), FloatPoint(Rx, Ry), CalculateCircleSteps(Min(Rx, Ry))); end; function Ellipse(const R: TRect): TArrayOfFloatPoint; begin Result := Ellipse( FloatPoint(0.5 * (R.Right + R.Left), 0.5 * (R.Bottom + R.Top)), FloatPoint(0.5 * (R.Right - R.Left), 0.5 * (R.Bottom - R.Top))); end; function Ellipse(const R: TFloatRect): TArrayOfFloatPoint; begin Result := Ellipse( FloatPoint(0.5 * (R.Right + R.Left), 0.5 * (R.Bottom + R.Top)), FloatPoint(0.5 * (R.Right - R.Left), 0.5 * (R.Bottom - R.Top))); end; function Ellipse(const R: TRect; Steps: Integer): TArrayOfFloatPoint; begin Result := Ellipse( FloatPoint(0.5 * (R.Right + R.Left), 0.5 * (R.Bottom + R.Top)), FloatPoint(0.5 * (R.Right - R.Left), 0.5 * (R.Bottom - R.Top)), Steps); end; function Ellipse(const R: TFloatRect; Steps: Integer): TArrayOfFloatPoint; begin Result := Ellipse( FloatPoint(0.5 * (R.Right + R.Left), 0.5 * (R.Bottom + R.Top)), FloatPoint(0.5 * (R.Right - R.Left), 0.5 * (R.Bottom - R.Top)), Steps); end; function Star(const X, Y, Radius: TFloat; Vertices: Integer = 5; Rotation: TFloat = 0): TArrayOfFloatPoint; var Alpha, Ratio: TFloat; begin Alpha := Pi * (Vertices - 2 * ((Vertices - 1) shr 1)) / Vertices; Ratio := Sin(Alpha * 0.5) / Sin( Alpha * 0.5 + Pi / Vertices); Result := Star(X, Y, Ratio * Radius, Radius, Vertices, Rotation); end; function Star(const P: TFloatPoint; const Radius: TFloat; Vertices: Integer = 5; Rotation: TFloat = 0): TArrayOfFloatPoint; var Alpha, Ratio: TFloat; begin Alpha := Pi * (Vertices - 2 * ((Vertices - 1) shr 1)) / Vertices; Ratio := Sin(Alpha * 0.5) / Sin(Alpha * 0.5 + Pi / Vertices); Result := Star(P, Ratio * Radius, Radius, Vertices, Rotation); end; function Star(const X, Y, InnerRadius, OuterRadius: TFloat; Vertices: Integer = 5; Rotation: TFloat = 0): TArrayOfFloatPoint; begin Result := Star(FloatPoint(X, Y), InnerRadius, OuterRadius, Vertices, Rotation); end; function Star(const P: TFloatPoint; const InnerRadius, OuterRadius: TFloat; Vertices: Integer = 5; Rotation: TFloat = 0): TArrayOfFloatPoint; var I: Integer; M: TFloat; C, D: TFloatPoint; begin SetLength(Result, 2 * Vertices); M := System.Pi / Vertices; // calculate complex offset GR32_Math.SinCos(M, C.Y, C.X); // first item if Rotation = 0 then begin Result[0].X := OuterRadius + P.X; Result[0].Y := P.Y; D := C; end else begin GR32_Math.SinCos(Rotation, D.Y, D.X); Result[0].X := OuterRadius * D.X + P.X; Result[0].Y := OuterRadius * D.Y + P.Y; D := FloatPoint(D.X * C.X - D.Y * C.Y, D.Y * C.X + D.X * C.Y); end; // second item Result[1].X := InnerRadius * D.X + P.X; Result[1].Y := InnerRadius * D.Y + P.Y; // other items for I := 2 to (2 * Vertices) - 1 do begin D := FloatPoint(D.X * C.X - D.Y * C.Y, D.Y * C.X + D.X * C.Y); if I mod 2 = 0 then begin Result[I].X := OuterRadius * D.X + P.X; Result[I].Y := OuterRadius * D.Y + P.Y; end else begin Result[I].X := InnerRadius * D.X + P.X; Result[I].Y := InnerRadius * D.Y + P.Y; end; end; end; function Rectangle(const R: TFloatRect): TArrayOfFloatPoint; begin SetLength(Result, 4); Result[0] := R.TopLeft; Result[1] := FloatPoint(R.Right, R.Top); Result[2] := R.BottomRight; Result[3] := FloatPoint(R.Left, R.Bottom); end; function RoundRect(const R: TFloatRect; const Radius: TFloat): TArrayOfFloatPoint; var R2: TFloatRect; begin R2 := R; GR32.InflateRect(R2, -Radius, -Radius); Result := Grow(Rectangle(R2), Radius, jsRound, True); end; function BuildNormals(const Points: TArrayOfFloatPoint): TArrayOfFloatPoint; const EPSILON = 1E-4; var I, Count, NextI: Integer; dx, dy, f: Double; begin Count := Length(Points); SetLength(Result, Count); I := 0; NextI := 1; while I < Count do begin if NextI >= Count then NextI := 0; dx := Points[NextI].X - Points[I].X; dy := Points[NextI].Y - Points[I].Y; f := GR32_Math.Hypot(dx, dy); if (f > EPSILON) then begin f := 1 / f; dx := dx * f; dy := dy * f; end; Result[I].X := dy; Result[I].Y := -dx; Inc(I); Inc(NextI); end; end; function BuildNormals(const Points: TArrayOfFixedPoint): TArrayOfFixedPoint; var I, Count, NextI: Integer; dx, dy, f: TFixed; begin Count := Length(Points); SetLength(Result, Count); I := 0; NextI := 1; while I < Count do begin if NextI >= Count then NextI := 0; dx := Points[NextI].X - Points[I].X; dy := Points[NextI].Y - Points[I].Y; f := GR32_Math.Hypot(dx, dy); if (f <> 0) then begin dx := FixedDiv(dx, f); dy := FixedDiv(dy, f); end; Result[I].X := dy; Result[I].Y := -dx; Inc(I); Inc(NextI); end; end; function Grow(const Points: TArrayOfFloatPoint; const Normals: TArrayOfFloatPoint; const Delta: TFloat; JoinStyle: TJoinStyle; Closed: Boolean; MiterLimit: TFloat): TArrayOfFloatPoint; overload; const BUFFSIZEINCREMENT = 128; MINDISTPIXEL = 1.414; // just a little bit smaller than sqrt(2), // -> set to about 2.5 for a similar output with the previous version var ResSize, BuffSize: Integer; PX, PY: TFloat; AngleInv, RMin: TFloat; A, B, Dm: TFloatPoint; procedure AddPoint(const LongDeltaX, LongDeltaY: TFloat); begin if ResSize = BuffSize then begin Inc(BuffSize, BUFFSIZEINCREMENT); SetLength(Result, BuffSize); end; Result[ResSize] := FloatPoint(PX + LongDeltaX, PY + LongDeltaY); Inc(ResSize); end; procedure AddMitered(const X1, Y1, X2, Y2: TFloat); var R, CX, CY: TFloat; begin CX := X1 + X2; CY := Y1 + Y2; R := X1 * CX + Y1 * CY; //(1 - cos(ß)) (range: 0 <= R <= 2) if R < RMin then begin AddPoint(Delta * X1, Delta * Y1); AddPoint(Delta * X2, Delta * Y2); end else begin R := Delta / R; AddPoint(CX * R, CY * R) end; end; procedure AddBevelled(const X1, Y1, X2, Y2: TFloat); var R: TFloat; begin R := X1 * Y2 - X2 * Y1; //cross product if R * Delta <= 0 then //ie angle is concave begin AddMitered(X1, Y1, X2, Y2); end else begin AddPoint(Delta * X1, Delta * Y1); AddPoint(Delta * X2, Delta * Y2); end; end; procedure AddRoundedJoin(const X1, Y1, X2, Y2: TFloat); var R, tmp, da: TFloat; ArcLen: Integer; I: Integer; C: TFloatPoint; begin R := X1 * Y2 - X2 * Y1; if R * Delta <= 0 then AddMitered(X1, Y1, X2, Y2) else begin if R < 0 then Dm.Y := -Abs(Dm.Y) else Dm.Y := Abs(Dm.Y); tmp := 1 - 0.5 * (Sqr(X2 - X1) + Sqr(Y2 - Y1)); da := 0.5 * Pi - tmp * (1 + Sqr(tmp) * 0.1667); // should be ArcCos(tmp); ArcLen := Round(Abs(da * AngleInv)); // should be trunc instead of round C.X := X1 * Delta; C.Y := Y1 * Delta; AddPoint(C.X, C.Y); for I := 1 to ArcLen - 1 do begin C := FloatPoint(C.X * Dm.X - C.Y * Dm.Y, C.Y * Dm.X + C.X * Dm.Y); AddPoint(C.X, C.Y); end; C.X := X2 * Delta; C.Y := Y2 * Delta; AddPoint(C.X, C.Y); end; end; procedure AddJoin(const X, Y, X1, Y1, X2, Y2: TFloat); begin PX := X; PY := Y; case JoinStyle of jsMiter: AddMitered(A.X, A.Y, B.X, B.Y); jsBevel: AddBevelled(A.X, A.Y, B.X, B.Y); jsRound: AddRoundedJoin(A.X, A.Y, B.X, B.Y); end; end; var I, L, H: Integer; begin Result := nil; if Length(Points) <= 1 then Exit; //MiterLimit = Sqrt(2/(1 - cos(ß))) //Sqr(MiterLimit) = 2/(1 - cos(ß)) //1 - cos(ß) = 2/Sqr(MiterLimit) = RMin; RMin := 2 / Sqr(MiterLimit); H := High(Points) - Ord(not Closed); while (H >= 0) and (Normals[H].X = 0) and (Normals[H].Y = 0) do Dec(H); {** all normals zeroed => Exit } if H < 0 then Exit; L := 0; while (Normals[L].X = 0) and (Normals[L].Y = 0) do Inc(L); if Closed then A := Normals[H] else A := Normals[L]; ResSize := 0; BuffSize := BUFFSIZEINCREMENT; SetLength(Result, BuffSize); // prepare if JoinStyle = jsRound then begin Dm.X := 1 - 0.5 * Min(3, Sqr(MINDISTPIXEL / Abs(Delta))); Dm.Y := Sqrt(1 - Sqr(Dm.X)); AngleInv := 1 / ArcCos(Dm.X); end; for I := L to H do begin B := Normals[I]; if (B.X = 0) and (B.Y = 0) then Continue; with Points[I] do AddJoin(X, Y, A.X, A.Y, B.X, B.Y); A := B; end; if not Closed then with Points[High(Points)] do AddJoin(X, Y, A.X, A.Y, A.X, A.Y); SetLength(Result, ResSize); end; function Grow(const Points: TArrayOfFloatPoint; const Delta: TFloat; JoinStyle: TJoinStyle; Closed: Boolean; MiterLimit: TFloat): TArrayOfFloatPoint; overload; var Normals: TArrayOfFloatPoint; begin Normals := BuildNormals(Points); Result := Grow(Points, Normals, Delta, JoinStyle, Closed, MiterLimit); end; function Grow(const Points: TArrayOfFixedPoint; const Normals: TArrayOfFixedPoint; const Delta: TFixed; JoinStyle: TJoinStyle = jsMiter; Closed: Boolean = True; MiterLimit: TFixed = DEFAULT_MITER_LIMIT_FIXED): TArrayOfFixedPoint; overload; const BUFFSIZEINCREMENT = 128; var I, L, H: Integer; ResSize, BuffSize: Integer; PX, PY, D, RMin: TFixed; A, B: TFixedPoint; procedure AddPoint(const LongDeltaX, LongDeltaY: TFixed); begin if ResSize = BuffSize then begin Inc(BuffSize, BUFFSIZEINCREMENT); SetLength(Result, BuffSize); end; with Result[ResSize] do begin X := PX + LongDeltaX; Y := PY + LongDeltaY; end; Inc(ResSize); end; procedure AddMitered(const X1, Y1, X2, Y2: TFixed); var R, CX, CY: TFixed; begin CX := X1 + X2; CY := Y1 + Y2; R := FixedMul(X1, CX) + FixedMul(Y1, CY); //(1 - cos(ß)) (range: 0 <= R <= 2) if R < RMin then begin AddPoint(FixedMul(D, X1), FixedMul(D, Y1)); AddPoint(FixedMul(D, X2), FixedMul(D, Y2)); end else begin R := FixedDiv(D, R); AddPoint(FixedMul(CX, R), FixedMul(CY, R)); end; end; procedure AddBevelled(const X1, Y1, X2, Y2: TFixed); var R: TFixed; begin R := X1 * Y2 - X2 * Y1; //cross product if R * D <= 0 then //ie angle is concave begin AddMitered(X1, Y1, X2, Y2); end else begin AddPoint(FixedMul(D, X1), FixedMul(D, Y1)); AddPoint(FixedMul(D, X2), FixedMul(D, Y2)); end; end; procedure AddRoundedJoin(const X1, Y1, X2, Y2: TFixed); var R: TFixed; a1, a2, da: TFloat; Arc: TArrayOfFixedPoint; ArcLen: Integer; begin R := FixedMul(X1, Y2) - FixedMul(X2, Y1); if R * D <= 0 then AddMitered(X1, Y1, X2, Y2) else begin a1 := ArcTan2(Y1, X1) * FixedToFloat; a2 := ArcTan2(Y2, X2) * FixedToFloat; da := a2 - a1; if da > Pi then a2 := a2 - TWOPI else if da < -Pi then a2 := a2 + TWOPI; Arc := BuildArc(FixedPoint(PX, PY), a1, a2, D); ArcLen := Length(Arc); if ResSize + ArcLen >= BuffSize then begin Inc(BuffSize, ArcLen); SetLength(Result, BuffSize); end; Move(Arc[0], Result[ResSize], Length(Arc) * SizeOf(TFixedPoint)); Inc(ResSize, ArcLen); end; end; procedure AddJoin(const X, Y, X1, Y1, X2, Y2: TFixed); begin PX := X; PY := Y; case JoinStyle of jsMiter: AddMitered(A.X, A.Y, B.X, B.Y); jsBevel: AddBevelled(A.X, A.Y, B.X, B.Y); jsRound: AddRoundedJoin(A.X, A.Y, B.X, B.Y); end; end; begin raise Exception.Create('Not yet fully implemented'); Result := nil; if Length(Points) <= 1 then Exit; D := Delta; //MiterLimit = Sqrt(2/(1 - cos(ß))) //Sqr(MiterLimit) = 2/(1 - cos(ß)) //1 - cos(ß) = 2/Sqr(MiterLimit) = RMin; RMin := FixedDiv($20000, FixedSqr(MiterLimit)); H := High(Points) - Ord(not Closed); while (H >= 0) and (Normals[H].X = 0) and (Normals[H].Y = 0) do Dec(H); {** all normals zeroed => Exit } if H < 0 then Exit; L := 0; while (Normals[L].X = 0) and (Normals[L].Y = 0) do Inc(L); if Closed then A := Normals[H] else A := Normals[L]; ResSize := 0; BuffSize := BUFFSIZEINCREMENT; SetLength(Result, BuffSize); for I := L to H do begin B := Normals[I]; if (B.X = 0) and (B.Y = 0) then Continue; with Points[I] do AddJoin(X, Y, A.X, A.Y, B.X, B.Y); A := B; end; if not Closed then with Points[High(Points)] do AddJoin(X, Y, A.X, A.Y, A.X, A.Y); SetLength(Result, ResSize); end; function Grow(const Points: TArrayOfFixedPoint; const Delta: TFixed; JoinStyle: TJoinStyle = jsMiter; Closed: Boolean = True; MiterLimit: TFixed = DEFAULT_MITER_LIMIT_FIXED): TArrayOfFixedPoint; overload; var Normals: TArrayOfFixedPoint; begin Normals := BuildNormals(Points); Result := Grow(Points, Normals, Delta, JoinStyle, Closed, MiterLimit); end; function ReversePolygon(const Points: TArrayOfFloatPoint): TArrayOfFloatPoint; var I, L: Integer; begin L := Length(Points); SetLength(Result, L); Dec(L); for I := 0 to L do Result[I] := Points[L - I]; end; function ReversePolygon(const Points: TArrayOfFixedPoint): TArrayOfFixedPoint; var I, L: Integer; begin L := Length(Points); SetLength(Result, L); Dec(L); for I := 0 to L do Result[I] := Points[L - I]; end; function BuildLineEnd(const P, N: TFloatPoint; const W: TFloat; EndStyle: TEndStyle): TArrayOfFloatPoint; overload; var a1, a2: TFloat; begin case EndStyle of esButt: begin Result := nil; end; esSquare: begin SetLength(Result, 2); Result[0].X := P.X + (N.X - N.Y) * W; Result[0].Y := P.Y + (N.Y + N.X) * W; Result[1].X := P.X - (N.X + N.Y) * W; Result[1].Y := P.Y - (N.Y - N.X) * W; end; esRound: begin a1 := ArcTan2(N.Y, N.X); a2 := ArcTan2(-N.Y, -N.X); if a2 < a1 then a2 := a2 + TWOPI; Result := BuildArc(P, a1, a2, W); end; end; end; function BuildLineEnd(const P, N: TFixedPoint; const W: TFixed; EndStyle: TEndStyle): TArrayOfFixedPoint; overload; var a1, a2: TFloat; begin case EndStyle of esButt: begin Result := nil; end; esSquare: begin SetLength(Result, 2); Result[0].X := P.X + (N.X - N.Y) * W; Result[0].Y := P.Y + (N.Y + N.X) * W; Result[1].X := P.X - (N.X + N.Y) * W; Result[1].Y := P.Y - (N.Y - N.X) * W; end; esRound: begin a1 := ArcTan2(N.Y, N.X); a2 := ArcTan2(-N.Y, -N.X); if a2 < a1 then a2 := a2 + TWOPI; Result := BuildArc(P, a1, a2, W); end; end; end; function BuildPolyline(const Points: TArrayOfFloatPoint; StrokeWidth: TFloat; JoinStyle: TJoinStyle; EndStyle: TEndStyle; MiterLimit: TFloat): TArrayOfFloatPoint; var L, H: Integer; Normals: TArrayOfFloatPoint; P1, P2, E1, E2: TArrayOfFloatPoint; V: TFloat; P: PFloatPoint; begin V := StrokeWidth * 0.5; Normals := BuildNormals(Points); H := High(Points) - 1; while (H >= 0) and (Normals[H].X = 0) and (Normals[H].Y = 0) do Dec(H); if H < 0 then Exit; L := 0; while (Normals[L].X = 0) and (Normals[L].Y = 0) do Inc(L); P1 := Grow(Points, Normals, V, JoinStyle, False, MiterLimit); P2 := ReversePolygon(Grow(Points, Normals, -V, JoinStyle, False, MiterLimit)); E1 := BuildLineEnd(Points[0], Normals[L], -V, EndStyle); E2 := BuildLineEnd(Points[High(Points)], Normals[H], V, EndStyle); SetLength(Result, Length(P1) + Length(P2) + Length(E1) + Length(E2)); P := @Result[0]; Move(E1[0], P^, Length(E1) * SizeOf(TFloatPoint)); Inc(P, Length(E1)); Move(P1[0], P^, Length(P1) * SizeOf(TFloatPoint)); Inc(P, Length(P1)); Move(E2[0], P^, Length(E2) * SizeOf(TFloatPoint)); Inc(P, Length(E2)); Move(P2[0], P^, Length(P2) * SizeOf(TFloatPoint)); end; function BuildPolyPolyLine(const Points: TArrayOfArrayOfFloatPoint; Closed: Boolean; StrokeWidth: TFloat; JoinStyle: TJoinStyle; EndStyle: TEndStyle; MiterLimit: TFloat): TArrayOfArrayOfFloatPoint; var I: Integer; P1, P2: TArrayOfFloatPoint; Dst: TArrayOfArrayOfFloatPoint; Normals: TArrayOfFloatPoint; begin if Closed then begin SetLength(Dst, Length(Points) * 2); for I := 0 to High(Points) do begin Normals := BuildNormals(Points[I]); P1 := Grow(Points[I], Normals, StrokeWidth * 0.5, JoinStyle, True, MiterLimit); P2 := Grow(Points[I], Normals, -StrokeWidth * 0.5, JoinStyle, True, MiterLimit); Dst[I * 2] := P1; Dst[I * 2 + 1] := ReversePolygon(P2); end; end else begin SetLength(Dst, Length(Points)); for I := 0 to High(Points) do Dst[I] := BuildPolyline(Points[I], StrokeWidth, JoinStyle, EndStyle); end; Result := Dst; end; function BuildPolyline(const Points: TArrayOfFixedPoint; StrokeWidth: TFixed; JoinStyle: TJoinStyle; EndStyle: TEndStyle; MiterLimit: TFixed): TArrayOfFixedPoint; var L, H: Integer; Normals: TArrayOfFixedPoint; P1, P2, E1, E2: TArrayOfFixedPoint; V: TFixed; P: PFixedPoint; begin V := StrokeWidth shr 1; Normals := BuildNormals(Points); H := High(Points) - 1; while (H >= 0) and (Normals[H].X = 0) and (Normals[H].Y = 0) do Dec(H); if H < 0 then Exit; L := 0; while (Normals[L].X = 0) and (Normals[L].Y = 0) do Inc(L); P1 := Grow(Points, Normals, V, JoinStyle, False, MiterLimit); P2 := ReversePolygon(Grow(Points, Normals, -V, JoinStyle, False, MiterLimit)); E1 := BuildLineEnd(Points[0], Normals[L], -V, EndStyle); E2 := BuildLineEnd(Points[High(Points)], Normals[H], V, EndStyle); SetLength(Result, Length(P1) + Length(P2) + Length(E1) + Length(E2)); P := @Result[0]; Move(E1[0], P^, Length(E1) * SizeOf(TFixedPoint)); Inc(P, Length(E1)); Move(P1[0], P^, Length(P1) * SizeOf(TFixedPoint)); Inc(P, Length(P1)); Move(E2[0], P^, Length(E2) * SizeOf(TFixedPoint)); Inc(P, Length(E2)); Move(P2[0], P^, Length(P2) * SizeOf(TFixedPoint)); end; function BuildPolyPolyLine(const Points: TArrayOfArrayOfFixedPoint; Closed: Boolean; StrokeWidth: TFixed; JoinStyle: TJoinStyle; EndStyle: TEndStyle; MiterLimit: TFixed): TArrayOfArrayOfFixedPoint; var I: Integer; P1, P2: TArrayOfFixedPoint; Dst: TArrayOfArrayOfFixedPoint; Normals: TArrayOfFixedPoint; begin if Closed then begin SetLength(Dst, Length(Points) * 2); for I := 0 to High(Points) do begin Normals := BuildNormals(Points[I]); P1 := Grow(Points[I], Normals, StrokeWidth shr 1, JoinStyle, True, MiterLimit); P2 := Grow(Points[I], Normals, -StrokeWidth shr 1, JoinStyle, True, MiterLimit); Dst[I * 2] := P1; Dst[I * 2 + 1] := ReversePolygon(P2); end; end else begin SetLength(Dst, Length(Points)); for I := 0 to High(Points) do Dst[I] := BuildPolyline(Points[I], StrokeWidth, JoinStyle, EndStyle); end; Result := Dst; end; function BuildDashedLine(const Points: TArrayOfFloatPoint; const DashArray: TArrayOfFloat; DashOffset: TFloat = 0; Closed: Boolean = False): TArrayOfArrayOfFloatPoint; const EPSILON = 1E-4; var I, J, DashIndex, len1, len2: Integer; Offset, Dist, v: TFloat; Delta: TFloatPoint; procedure AddPoint(X, Y: TFloat); var K: Integer; begin K := Length(Result[J]); SetLength(Result[J], K + 1); Result[J][K].X := X; Result[J][K].Y := Y; end; procedure AddDash(I: Integer); begin if i = 0 then begin Delta.X := Points[0].X - Points[High(Points)].X; Delta.Y := Points[0].Y - Points[High(Points)].Y; end else begin Delta.X := Points[I].X - Points[I - 1].X; Delta.Y := Points[I].Y - Points[I - 1].Y; end; Dist := GR32_Math.Hypot(Delta.X, Delta.Y); Offset := Offset + Dist; if (Dist > EPSILON) then begin Dist := 1 / Dist; Delta.X := Delta.X * Dist; Delta.Y := Delta.Y * Dist; end; while Offset > DashOffset do begin v := Offset - DashOffset; AddPoint(Points[I].X - v * Delta.X, Points[I].Y - v * Delta.Y); DashIndex := (DashIndex + 1) mod Length(DashArray); DashOffset := DashOffset + DashArray[DashIndex]; if Odd(DashIndex) then begin Inc(J); SetLength(Result, J + 1); end; end; if not Odd(DashIndex) then AddPoint(Points[I].X, Points[I].Y); end; begin if Length(Points) <= 0 then Exit; DashIndex := -1; Offset := 0; V := 0; for I := 0 to High(DashArray) do V := V + DashArray[I]; DashOffset := Wrap(DashOffset, V); DashOffset := DashOffset - V; while DashOffset < 0 do begin Inc(DashIndex); DashOffset := DashOffset + DashArray[DashIndex]; end; J := 0; // note to self: second dimension might not be zero by default! SetLength(Result, 1, 0); if not Odd(DashIndex) then AddPoint(Points[0].X, Points[0].Y); for I := 1 to High(Points) do AddDash(I); if Closed then begin AddDash(0); len1 := Length(Result[0]); len2 := Length(Result[J]); if (len1 > 0) and (len2 > 0) then begin SetLength(Result[0], len1 + len2 -1); Move(Result[0][0], Result[0][len2 - 1], SizeOf(TFloatPoint) * len1); Move(Result[J][0], Result[0][0], SizeOf(TFloatPoint) * len2); SetLength(Result, J); Dec(J); end; end; if Length(Result[J]) = 0 then SetLength(Result, J); end; function BuildDashedLine(const Points: TArrayOfFixedPoint; const DashArray: TArrayOfFixed; DashOffset: TFixed = 0; Closed: Boolean = False): TArrayOfArrayOfFixedPoint; var I, J, DashIndex, Len1, Len2: Integer; Offset, Dist, v: TFixed; Delta: TFixedPoint; procedure AddPoint(X, Y: TFixed); var K: Integer; begin K := Length(Result[J]); SetLength(Result[J], K + 1); Result[J][K].X := X; Result[J][K].Y := Y; end; procedure AddDash(I: Integer); begin if i = 0 then begin Delta.X := Points[0].X - Points[High(Points)].X; Delta.Y := Points[0].Y - Points[High(Points)].Y; end else begin Delta.X := Points[I].X - Points[I - 1].X; Delta.Y := Points[I].Y - Points[I - 1].Y; end; Dist := GR32_Math.Hypot(Delta.X, Delta.Y); Offset := Offset + Dist; if (Dist > 0) then begin Delta.X := FixedDiv(Delta.X, Dist); Delta.Y := FixedDiv(Delta.Y, Dist); end; while Offset > DashOffset do begin v := Offset - DashOffset; AddPoint(Points[I].X - FixedMul(v, Delta.X), Points[I].Y - FixedMul(v, Delta.Y)); DashIndex := (DashIndex + 1) mod Length(DashArray); DashOffset := DashOffset + DashArray[DashIndex]; if Odd(DashIndex) then begin Inc(J); SetLength(Result, J + 1); end; end; if not Odd(DashIndex) then AddPoint(Points[I].X, Points[I].Y); end; begin if Length(Points) <= 0 then Exit; DashIndex := -1; Offset := 0; V := 0; for I := 0 to High(DashArray) do V := V + DashArray[I]; DashOffset := Wrap(DashOffset, V); DashOffset := DashOffset - V; while DashOffset < 0 do begin Inc(DashIndex); DashOffset := DashOffset + DashArray[DashIndex]; end; J := 0; // note to self: second dimension might not be zero by default! SetLength(Result, 1, 0); if not Odd(DashIndex) then AddPoint(Points[0].X, Points[0].Y); for I := 1 to High(Points) do AddDash(I); if Closed then begin AddDash(0); Len1 := Length(Result[0]); Len2 := Length(Result[J]); if (Len1 > 0) and (Len2 > 0) then begin SetLength(Result[0], len1 + len2 -1); Move(Result[0][0], Result[0][len2 - 1], SizeOf(TFixedPoint) * Len1); Move(Result[J][0], Result[0][0], SizeOf(TFixedPoint) * Len2); SetLength(Result, J); Dec(J); end; end; if Length(Result[J]) = 0 then SetLength(Result, J); end; function InterpolateX(X: TFloat; const P1, P2: TFloatPoint): TFloatPoint; overload; var W: Double; begin W := (X - P1.X) / (P2.X - P1.X); Result.X := X; Result.Y := P1.Y + W * (P2.Y - P1.Y); end; function InterpolateY(Y: TFloat; const P1, P2: TFloatPoint): TFloatPoint; overload; var W: Double; begin W := (Y - P1.Y) / (P2.Y - P1.Y); Result.Y := Y; Result.X := P1.X + W * (P2.X - P1.X); end; function GetCode(const P: TFloatPoint; const R: TFloatRect): Integer; overload; {$IFDEF USEINLINING}inline;{$ENDIF} begin Result := Ord(P.X >= R.Left) or (Ord(P.X <= R.Right) shl 1) or (Ord(P.Y >= R.Top) shl 2) or (Ord(P.Y <= R.Bottom) shl 3); end; function ClipPolygon(const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect): TArrayOfFloatPoint; type TInterpolateProc = function(X: TFloat; const P1, P2: TFloatPoint): TFloatPoint; const SAFEOVERSIZE = 5; POPCOUNT: array [0..15] of Integer = (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4); var I, J, K, L, N: Integer; X, Y, Z, Code, Count: Integer; Codes: PByteArray; NextIndex: PIntegerArray; Temp: PFloatPointArray; label ExitProc; procedure AddPoint(Index: Integer; const P: TFloatPoint); begin Temp[K] := P; Codes[K] := GetCode(P, ClipRect); Inc(K); Inc(Count); end; function ClipEdges(Mask: Integer; V: TFloat; Interpolate: TInterpolateProc): Boolean; var I, NextI, StopIndex: Integer; begin I := 0; while (I < K) and (Codes[I] and Mask = 0) do Inc(I); Result := I = K; if Result then { all points outside } begin ClipPolygon := nil; Result := True; Exit; end; StopIndex := I; repeat NextI := NextIndex[I]; if Codes[NextI] and Mask = 0 then { inside -> outside } begin NextIndex[I] := K; NextIndex[K] := K + 1; AddPoint(I, Interpolate(V, Temp[I], Temp[NextI])); while Codes[NextI] and Mask = 0 do begin Dec(Count); Codes[NextI] := 0; I := NextI; NextI := NextIndex[I]; end; { outside -> inside } NextIndex[I] := K; NextIndex[K] := NextI; AddPoint(I, Interpolate(V, Temp[I], Temp[NextI])); end; I := NextI; until I = StopIndex; end; begin N := Length(Points); {$IFDEF USESTACKALLOC} Codes := StackAlloc(N * SAFEOVERSIZE * SizeOf(Byte)); {$ELSE} GetMem(Codes, N * SAFEOVERSIZE * SizeOf(Byte)); {$ENDIF} X := 15; Y := 0; for I := 0 to N - 1 do begin Code := GetCode(Points[I], ClipRect); Codes[I] := Code; X := X and Code; Y := Y or Code; end; if X = 15 then { all points inside } begin Result := Points; end else if Y <> 15 then { all points outside } begin Result := nil; end else begin Count := N; Z := Codes[N - 1]; for I := 0 to N - 1 do begin Code := Codes[I]; Inc(Count, POPCOUNT[Z xor Code]); Z := Code; end; {$IFDEF USESTACKALLOC} Temp := StackAlloc(Count * SizeOf(TFloatPoint)); NextIndex := StackAlloc(Count * SizeOf(TFloatPoint)); {$ELSE} GetMem(Temp, Count * SizeOf(TFloatPoint)); GetMem(NextIndex, Count * SizeOf(TFloatPoint)); {$ENDIF} Move(Points[0], Temp[0], N * SizeOf(TFloatPoint)); for I := 0 to N - 2 do NextIndex[I] := I + 1; NextIndex[N - 1] := 0; Count := N; K := N; if X and 1 = 0 then if ClipEdges(1, ClipRect.Left, InterpolateX) then goto ExitProc; if X and 2 = 0 then if ClipEdges(2, ClipRect.Right, InterpolateX) then goto ExitProc; if X and 4 = 0 then if ClipEdges(4, ClipRect.Top, InterpolateY) then goto ExitProc; if X and 8 = 0 then if ClipEdges(8, ClipRect.Bottom, InterpolateY) then goto ExitProc; SetLength(Result, Count); { start with first point inside the clipping rectangle } I := 0; while Codes[I] = 0 do I := NextIndex[I]; J := I; L := 0; repeat Result[L] := Temp[I]; Inc(L); I := NextIndex[I]; until I = J; ExitProc: {$IFDEF USESTACKALLOC} StackFree(NextIndex); StackFree(Temp); {$ELSE} FreeMem(NextIndex); FreeMem(Temp); {$ENDIF} end; {$IFDEF USESTACKALLOC} StackFree(Codes); {$ELSE} FreeMem(Codes); {$ENDIF} end; function InterpolateX(X: TFixed; const P1, P2: TFixedPoint): TFixedPoint; overload; var W: TFixed; begin W := FixedDiv(X - P1.X, P2.X - P1.X); Result.X := X; Result.Y := P1.Y + FixedMul(W, P2.Y - P1.Y); end; function InterpolateY(Y: TFixed; const P1, P2: TFixedPoint): TFixedPoint; overload; var W: TFixed; begin W := FixedDiv(Y - P1.Y, P2.Y - P1.Y); Result.Y := Y; Result.X := P1.X + FixedMul(W, P2.X - P1.X); end; function GetCode(const P: TFixedPoint; const R: TFixedRect): Integer; overload; {$IFDEF USEINLINING}inline;{$ENDIF} begin Result := Ord(P.X >= R.Left) or (Ord(P.X <= R.Right) shl 1) or (Ord(P.Y >= R.Top) shl 2) or (Ord(P.Y <= R.Bottom) shl 3); end; function ClipPolygon(const Points: TArrayOfFixedPoint; const ClipRect: TFixedRect): TArrayOfFixedPoint; type TInterpolateProc = function(X: TFixed; const P1, P2: TFixedPoint): TFixedPoint; const SAFEOVERSIZE = 5; POPCOUNT: array [0..15] of Integer = (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4); var I, J, K, L, N: Integer; X, Y, Z, Code, Count: Integer; Codes: PByteArray; NextIndex: PIntegerArray; Temp: PFixedPointArray; label ExitProc; procedure AddPoint(Index: Integer; const P: TFixedPoint); begin Temp[K] := P; Codes[K] := GetCode(P, ClipRect); Inc(K); Inc(Count); end; function ClipEdges(Mask: Integer; V: TFixed; Interpolate: TInterpolateProc): Boolean; var I, NextI, StopIndex: Integer; begin I := 0; while (I < K) and (Codes[I] and Mask = 0) do Inc(I); Result := I = K; if Result then { all points outside } begin ClipPolygon := nil; Result := True; Exit; end; StopIndex := I; repeat NextI := NextIndex[I]; if Codes[NextI] and Mask = 0 then { inside -> outside } begin NextIndex[I] := K; NextIndex[K] := K + 1; AddPoint(I, Interpolate(V, Temp[I], Temp[NextI])); while Codes[NextI] and Mask = 0 do begin Dec(Count); Codes[NextI] := 0; I := NextI; NextI := NextIndex[I]; end; { outside -> inside } NextIndex[I] := K; NextIndex[K] := NextI; AddPoint(I, Interpolate(V, Temp[I], Temp[NextI])); end; I := NextI; until I = StopIndex; end; begin N := Length(Points); {$IFDEF USESTACKALLOC} Codes := StackAlloc(N * SAFEOVERSIZE * SizeOf(Byte)); {$ELSE} GetMem(Codes, N * SAFEOVERSIZE * SizeOf(Byte)); {$ENDIF} X := 15; Y := 0; for I := 0 to N - 1 do begin Code := GetCode(Points[I], ClipRect); Codes[I] := Code; X := X and Code; Y := Y or Code; end; if X = 15 then { all points inside } begin Result := Points; end else if Y <> 15 then { all points outside } begin Result := nil; end else begin Count := N; Z := Codes[N - 1]; for I := 0 to N - 1 do begin Code := Codes[I]; Inc(Count, POPCOUNT[Z xor Code]); Z := Code; end; {$IFDEF USESTACKALLOC} Temp := StackAlloc(Count * SizeOf(TFixedPoint)); NextIndex := StackAlloc(Count * SizeOf(TFixedPoint)); {$ELSE} GetMem(Temp, Count * SizeOf(TFixedPoint)); GetMem(NextIndex, Count * SizeOf(TFixedPoint)); {$ENDIF} Move(Points[0], Temp[0], N * SizeOf(TFixedPoint)); for I := 0 to N - 2 do NextIndex[I] := I + 1; NextIndex[N - 1] := 0; Count := N; K := N; if X and 1 = 0 then if ClipEdges(1, ClipRect.Left, InterpolateX) then goto ExitProc; if X and 2 = 0 then if ClipEdges(2, ClipRect.Right, InterpolateX) then goto ExitProc; if X and 4 = 0 then if ClipEdges(4, ClipRect.Top, InterpolateY) then goto ExitProc; if X and 8 = 0 then if ClipEdges(8, ClipRect.Bottom, InterpolateY) then goto ExitProc; SetLength(Result, Count); { start with first point inside the clipping rectangle } I := 0; while Codes[I] = 0 do I := NextIndex[I]; J := I; L := 0; repeat Result[L] := Temp[I]; Inc(L); I := NextIndex[I]; until I = J; ExitProc: {$IFDEF USESTACKALLOC} StackFree(NextIndex); StackFree(Temp); {$ELSE} FreeMem(NextIndex); FreeMem(Temp); {$ENDIF} end; {$IFDEF USESTACKALLOC} StackFree(Codes); {$ELSE} FreeMem(Codes); {$ENDIF} end; function CatPolyPolygon(const P1, P2: TArrayOfArrayOfFloatPoint): TArrayOfArrayOfFloatPoint; var L1, L2: Integer; begin L1 := Length(P1); L2 := Length(P2); SetLength(Result, L1 + L2); Move(P1[0], Result[0], L1 * SizeOf(TFloatPoint)); Move(P2[0], Result[L1], L2 * SizeOf(TFloatPoint)); end; function CatPolyPolygon(const P1, P2: TArrayOfArrayOfFixedPoint): TArrayOfArrayOfFixedPoint; overload; var L1, L2: Integer; begin L1 := Length(P1); L2 := Length(P2); SetLength(Result, L1 + L2); Move(P1[0], Result[0], L1 * SizeOf(TFixedPoint)); Move(P2[0], Result[L1], L2 * SizeOf(TFixedPoint)); end; function PolygonBounds(const Points: TArrayOfFloatPoint): TFloatRect; var I: Integer; begin Assert(Length(Points) > 0); Result.Left := Points[0].X; Result.Top := Points[0].Y; Result.Right := Points[0].X; Result.Bottom := Points[0].Y; for I := 1 to High(Points) do begin Result.Left := Min(Result.Left, Points[I].X); Result.Right := Max(Result.Right, Points[I].X); Result.Top := Min(Result.Top, Points[I].Y); Result.Bottom := Max(Result.Bottom, Points[I].Y); end; end; function PolygonBounds(const Points: TArrayOfFixedPoint): TFixedRect; var I: Integer; begin Assert(Length(Points) > 0); Result.Left := Points[0].X; Result.Top := Points[0].Y; Result.Right := Points[0].X; Result.Bottom := Points[0].Y; for I := 1 to High(Points) do begin Result.Left := Min(Result.Left, Points[I].X); Result.Right := Max(Result.Right, Points[I].X); Result.Top := Min(Result.Top, Points[I].Y); Result.Bottom := Max(Result.Bottom, Points[I].Y); end; end; function PolypolygonBounds(const Points: TArrayOfArrayOfFloatPoint): TFloatRect; var I: Integer; R: TFloatRect; begin Assert(Length(Points) > 0); Result := PolygonBounds(Points[0]); for I := 1 to High(Points) do begin R := PolygonBounds(Points[I]); Result.Left := Min(Result.Left, R.Left); Result.Right := Max(Result.Right, R.Right); Result.Top := Min(Result.Top, R.Top); Result.Bottom := Max(Result.Bottom, R.Bottom); end; end; function PolypolygonBounds(const Points: TArrayOfArrayOfFixedPoint): TFixedRect; var I: Integer; R: TFixedRect; begin Assert(Length(Points) > 0); Result := PolygonBounds(Points[0]); for I := 1 to High(Points) do begin R := PolygonBounds(Points[I]); Result.Left := Min(Result.Left, R.Left); Result.Right := Max(Result.Right, R.Right); Result.Top := Min(Result.Top, R.Top); Result.Bottom := Max(Result.Bottom, R.Bottom); end; end; // Scales to a polygon (TArrayOfFloatPoint) function ScalePolygon(const Points: TArrayOfFloatPoint; ScaleX, ScaleY: TFloat): TArrayOfFloatPoint; var I, L: Integer; begin L := Length(Points); SetLength(Result, L); for I := 0 to L - 1 do begin Result[I].X := Points[I].X * ScaleX; Result[I].Y := Points[I].Y * ScaleY; end; end; // Scales to a polygon (TArrayOfFixedPoint) function ScalePolygon(const Points: TArrayOfFixedPoint; ScaleX, ScaleY: TFixed): TArrayOfFixedPoint; var I, L: Integer; begin L := Length(Points); SetLength(Result, L); for I := 0 to L - 1 do begin Result[I].X := FixedMul(Points[I].X, ScaleX); Result[I].Y := FixedMul(Points[I].Y, ScaleY); end; end; // Scales all sub polygons in a complex polygon (TArrayOfArrayOfFloatPoint) function ScalePolyPolygon(const Points: TArrayOfArrayOfFloatPoint; ScaleX, ScaleY: TFloat): TArrayOfArrayOfFloatPoint; var I, L: Integer; begin L := Length(Points); SetLength(Result, L); for I := 0 to L - 1 do Result[I] := ScalePolygon(Points[I], ScaleX, ScaleY); end; // Scales all sub polygons in a complex polygon (TArrayOfArrayOfFixedPoint) function ScalePolyPolygon(const Points: TArrayOfArrayOfFixedPoint; ScaleX, ScaleY: TFixed): TArrayOfArrayOfFixedPoint; var I, L: Integer; begin L := Length(Points); SetLength(Result, L); for I := 0 to L - 1 do Result[I] := ScalePolygon(Points[I], ScaleX, ScaleY); end; // Scales a polygon (TArrayOfFloatPoint) procedure ScalePolygonInplace(const Points: TArrayOfFloatPoint; ScaleX, ScaleY: TFloat); var I: Integer; begin for I := 0 to Length(Points) - 1 do begin Points[I].X := Points[I].X * ScaleX; Points[I].Y := Points[I].Y * ScaleY; end; end; // Scales a polygon (TArrayOfFixedPoint) procedure ScalePolygonInplace(const Points: TArrayOfFixedPoint; ScaleX, ScaleY: TFixed); var I: Integer; begin for I := 0 to Length(Points) - 1 do begin Points[I].X := FixedMul(Points[I].X, ScaleX); Points[I].Y := FixedMul(Points[I].Y, ScaleY); end; end; // Scales all sub polygons in a complex polygon (TArrayOfArrayOfFloatPoint) procedure ScalePolyPolygonInplace(const Points: TArrayOfArrayOfFloatPoint; ScaleX, ScaleY: TFloat); var I: Integer; begin for I := 0 to Length(Points) - 1 do ScalePolygonInplace(Points[I], ScaleX, ScaleY); end; // Scales all sub polygons in a complex polygon (TArrayOfArrayOfFixedPoint) procedure ScalePolyPolygonInplace(const Points: TArrayOfArrayOfFixedPoint; ScaleX, ScaleY: TFixed); var I: Integer; begin for I := 0 to Length(Points) - 1 do ScalePolygonInplace(Points[I], ScaleX, ScaleY); end; // Translates a polygon (TArrayOfFloatPoint) function TranslatePolygon(const Points: TArrayOfFloatPoint; OffsetX, OffsetY: TFloat): TArrayOfFloatPoint; var I, Len: Integer; begin Len := Length(Points); SetLength(Result, Len); for I := 0 to Len - 1 do begin Result[I].X := Points[I].X + OffsetX; Result[I].Y := Points[I].Y + OffsetY; end; end; // Translates a polygon (TArrayOfFixedPoint) function TranslatePolygon(const Points: TArrayOfFixedPoint; OffsetX, OffsetY: TFixed): TArrayOfFixedPoint; var I, Len: Integer; begin Len := Length(Points); SetLength(Result, Len); for I := 0 to Len - 1 do begin Result[I].X := Points[I].X + OffsetX; Result[I].Y := Points[I].Y + OffsetY; end; end; // Translates all sub polygons in a complex polygon (TArrayOfArrayOfFloatPoint) function TranslatePolyPolygon(const Points: TArrayOfArrayOfFloatPoint; OffsetX, OffsetY: TFloat): TArrayOfArrayOfFloatPoint; var I, L: Integer; begin L := Length(Points); SetLength(Result, L); for I := 0 to L - 1 do Result[I] := TranslatePolygon(Points[I], OffsetX, OffsetY); end; // Translates all sub polygons in a complex polygon (TArrayOfArrayOfFixedPoint) function TranslatePolyPolygon(const Points: TArrayOfArrayOfFixedPoint; OffsetX, OffsetY: TFixed): TArrayOfArrayOfFixedPoint; var I, L: Integer; begin L := Length(Points); SetLength(Result, L); for I := 0 to L - 1 do Result[I] := TranslatePolygon(Points[I], OffsetX, OffsetY); end; procedure TranslatePolygonInplace(const Points: TArrayOfFloatPoint; OffsetX, OffsetY: TFloat); var I: Integer; begin for I := 0 to Length(Points) - 1 do begin Points[I].X := Points[I].X + OffsetX; Points[I].Y := Points[I].Y + OffsetY; end; end; procedure TranslatePolygonInplace(const Points: TArrayOfFixedPoint; OffsetX, OffsetY: TFixed); var I: Integer; begin for I := 0 to Length(Points) - 1 do begin Points[I].X := Points[I].X + OffsetX; Points[I].Y := Points[I].Y + OffsetY; end; end; // Translates all sub polygons in a complex polygon (TArrayOfArrayOfFloatPoint) procedure TranslatePolyPolygonInplace(const Points: TArrayOfArrayOfFloatPoint; OffsetX, OffsetY: TFloat); var I: Integer; begin for I := 0 to Length(Points) - 1 do TranslatePolygonInplace(Points[I], OffsetX, OffsetY); end; // Translates all sub polygons in a complex polygon (TArrayOfArrayOfFixedPoint) procedure TranslatePolyPolygonInplace(const Points: TArrayOfArrayOfFixedPoint; OffsetX, OffsetY: TFixed); var I: Integer; begin for I := 0 to Length(Points) - 1 do TranslatePolygonInplace(Points[I], OffsetX, OffsetY); end; // Applies transformation to a polygon (TArrayOfFloatPoint) function TransformPolygon(const Points: TArrayOfFloatPoint; Transformation: TTransformation): TArrayOfFloatPoint; var I: Integer; begin SetLength(Result, Length(Points)); for I := 0 to High(Result) do TTransformationAccess(Transformation).TransformFloat(Points[I].X, Points[I].Y, Result[I].X, Result[I].Y); end; // Applies transformation to a polygon (TArrayOfFixedPoint) function TransformPolygon(const Points: TArrayOfFixedPoint; Transformation: TTransformation): TArrayOfFixedPoint; var I: Integer; begin SetLength(Result, Length(Points)); for I := 0 to High(Result) do TTransformationAccess(Transformation).TransformFixed(Points[I].X, Points[I].Y, Result[I].X, Result[I].Y); end; // Applies transformation to all sub polygons in a complex polygon function TransformPolyPolygon(const Points: TArrayOfArrayOfFloatPoint; Transformation: TTransformation): TArrayOfArrayOfFloatPoint; var I: Integer; begin SetLength(Result, Length(Points)); TTransformationAccess(Transformation).PrepareTransform; for I := 0 to High(Result) do Result[I] := TransformPolygon(Points[I], Transformation); end; // Applies transformation to all sub polygons in a complex polygon function TransformPolyPolygon(const Points: TArrayOfArrayOfFixedPoint; Transformation: TTransformation): TArrayOfArrayOfFixedPoint; var I: Integer; begin SetLength(Result, Length(Points)); TTransformationAccess(Transformation).PrepareTransform; for I := 0 to High(Result) do Result[I] := TransformPolygon(Points[I], Transformation); end; function BuildPolygonF(const Data: array of TFloat): TArrayOfFloatPoint; var Index, Count: Integer; begin Count := Length(Data) div 2; SetLength(Result, Count); if Count = 0 then Exit; for Index := 0 to Count - 1 do begin Result[Index].X := Data[Index * 2]; Result[Index].Y := Data[Index * 2 + 1]; end; end; function BuildPolygonX(const Data: array of TFixed): TArrayOfFixedPoint; var Index, Count: Integer; begin Count := Length(Data) div 2; SetLength(Result, Count); if Count = 0 then Exit; for Index := 0 to Count - 1 do begin Result[Index].X := Data[Index * 2]; Result[Index].Y := Data[Index * 2 + 1]; end; end; // Copy data from Polygon to simple PolyPolygon (using 1 sub polygon only) function PolyPolygon(const Points: TArrayOfFloatPoint) : TArrayOfArrayOfFloatPoint; begin SetLength(Result, 1); Result[0] := Points; end; function PolyPolygon(const Points: TArrayOfFixedPoint) : TArrayOfArrayOfFixedPoint; begin SetLength(Result, 1); Result[0] := Points; end; function PointToFloatPoint(const Points: TArrayOfPoint): TArrayOfFloatPoint; var Index: Integer; begin if Length(Points) > 0 then begin SetLength(Result, Length(Points)); for Index := 0 to Length(Points) - 1 do begin Result[Index].X := Points[Index].X; Result[Index].Y := Points[Index].Y; end; end; end; function PointToFloatPoint(const Points: TArrayOfArrayOfPoint): TArrayOfArrayOfFloatPoint; var Index, PointIndex: Integer; begin if Length(Points) > 0 then begin SetLength(Result, Length(Points)); for Index := 0 to Length(Points) - 1 do begin SetLength(Result[Index], Length(Points[Index])); for PointIndex := 0 to Length(Points[Index]) - 1 do begin Result[Index, PointIndex].X := Points[Index, PointIndex].X; Result[Index, PointIndex].Y := Points[Index, PointIndex].Y; end; end; end; end; function PointToFixedPoint(const Points: TArrayOfPoint): TArrayOfFixedPoint; var Index: Integer; begin if Length(Points) > 0 then begin SetLength(Result, Length(Points)); for Index := 0 to Length(Points) - 1 do begin Result[Index].X := Fixed(Points[Index].X); Result[Index].Y := Fixed(Points[Index].Y); end; end; end; function PointToFixedPoint(const Points: TArrayOfArrayOfPoint): TArrayOfArrayOfFixedPoint; var Index, PointIndex: Integer; begin if Length(Points) > 0 then begin SetLength(Result, Length(Points)); for Index := 0 to Length(Points) - 1 do begin SetLength(Result[Index], Length(Points[Index])); for PointIndex := 0 to Length(Points[Index]) - 1 do begin Result[Index, PointIndex].X := Fixed(Points[Index, PointIndex].X); Result[Index, PointIndex].Y := Fixed(Points[Index, PointIndex].Y); end; end; end; end; // Converts an array of points in TFixed format to an array of points in TFloat format function FixedPointToFloatPoint(const Points: TArrayOfFixedPoint) : TArrayOfFloatPoint; var Index: Integer; begin if Length(Points) > 0 then begin SetLength(Result, Length(Points)); for Index := 0 to Length(Points) - 1 do begin Result[Index].X := Points[Index].X * FixedToFloat; Result[Index].Y := Points[Index].Y * FixedToFloat; end; end; end; // Converts an array of array of points in TFixed format to an array of array of points in TFloat format function FixedPointToFloatPoint(const Points: TArrayOfArrayOfFixedPoint) : TArrayOfArrayOfFloatPoint; var Index, PointIndex: Integer; begin if Length(Points) > 0 then begin SetLength(Result, Length(Points)); for Index := 0 to Length(Points) - 1 do begin SetLength(Result[Index], Length(Points[Index])); for PointIndex := 0 to Length(Points[Index]) - 1 do begin Result[Index, PointIndex].X := Points[Index, PointIndex].X * FixedToFloat; Result[Index, PointIndex].Y := Points[Index, PointIndex].Y * FixedToFloat; end; end; end; end; // Converts an array of points in TFixed format to an array of points in TFloat format function FloatPointToFixedPoint(const Points: TArrayOfFloatPoint) : TArrayOfFixedPoint; var Index: Integer; begin if Length(Points) > 0 then begin SetLength(Result, Length(Points)); for Index := 0 to Length(Points) - 1 do begin Result[Index].X := Fixed(Points[Index].X); Result[Index].Y := Fixed(Points[Index].Y); end; end; end; // Converts an array of array of points in TFixed format to an array of array of points in TFloat format function FloatPointToFixedPoint(const Points: TArrayOfArrayOfFloatPoint) : TArrayOfArrayOfFixedPoint; var Index, PointIndex: Integer; begin if Length(Points) > 0 then begin SetLength(Result, Length(Points)); for Index := 0 to Length(Points) - 1 do begin SetLength(Result[Index], Length(Points[Index])); for PointIndex := 0 to Length(Points[Index]) - 1 do begin Result[Index, PointIndex].X := Fixed(Points[Index, PointIndex].X); Result[Index, PointIndex].Y := Fixed(Points[Index, PointIndex].Y); end; end; end; end; end. |
Added src/graphics32/GR32_XPThemes.pas.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | unit GR32_XPThemes; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are 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/ * * 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. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Andre Beckedorf * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC} LCLIntf, LCLType, {$IFDEF Windows} Windows, {$ENDIF} {$IFDEF UNIX} Unix, BaseUnix, {$ENDIF} {$ELSE} Windows, {$ENDIF} SysUtils; {$IFDEF Windows} { Internal support for Windows XP themes } var USE_THEMES: Boolean = False; SCROLLBAR_THEME: THandle = 0; GLOBALS_THEME: THandle = 0; const THEMEMGR_VERSION = 1; WM_THEMECHANGED = $031A; { "Scrollbar" Parts & States } { SCROLLBARPARTS } SBP_ARROWBTN = 1; SBP_THUMBBTNHORZ = 2; SBP_THUMBBTNVERT = 3; SBP_LOWERTRACKHORZ = 4; SBP_UPPERTRACKHORZ = 5; SBP_LOWERTRACKVERT = 6; SBP_UPPERTRACKVERT = 7; SBP_GRIPPERHORZ = 8; SBP_GRIPPERVERT = 9; SBP_SIZEBOX = 10; { ARROWBTNSTATES } ABS_UPNORMAL = 1; ABS_UPHOT = 2; ABS_UPPRESSED = 3; ABS_UPDISABLED = 4; ABS_DOWNNORMAL = 5; ABS_DOWNHOT = 6; ABS_DOWNPRESSED = 7; ABS_DOWNDISABLED = 8; ABS_LEFTNORMAL = 9; ABS_LEFTHOT = 10; ABS_LEFTPRESSED = 11; ABS_LEFTDISABLED = 12; ABS_RIGHTNORMAL = 13; ABS_RIGHTHOT = 14; ABS_RIGHTPRESSED = 15; ABS_RIGHTDISABLED = 16; { SCROLLBARSTATES } SCRBS_NORMAL = 1; SCRBS_HOT = 2; SCRBS_PRESSED = 3; SCRBS_DISABLED = 4; { SIZEBOXSTATES } SZB_RIGHTALIGN = 1; SZB_LEFTALIGN = 2; { Access to uxtheme.dll } type HIMAGELIST = THandle; HTHEME = THandle; _MARGINS = record cxLeftWidth: Integer; // width of left border that retains its size cxRightWidth: Integer; // width of right border that retains its size cyTopHeight: Integer; // height of top border that retains its size cyBottomHeight: Integer; // height of bottom border that retains its size end; MARGINS = _MARGINS; PMARGINS = ^MARGINS; TMargins = MARGINS; var OpenThemeData: function(hwnd: HWND; pszClassList: LPCWSTR): HTHEME; stdcall; CloseThemeData: function(hTheme: HTHEME): HRESULT; stdcall; DrawThemeBackground: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const Rect: TRect; pClipRect: PRect): HRESULT; stdcall; DrawThemeEdge: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pDestRect: TRect; uEdge, uFlags: UINT; pContentRect: PRECT): HRESULT; stdcall; GetThemeColor: function(hTheme: HTHEME; iPartId, iStateId, iPropId: Integer; var pColor: COLORREF): HRESULT; stdcall; GetThemeMetric: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId, iPropId: Integer; var piVal: Integer): HRESULT; stdcall; GetThemeMargins: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId, iPropId: Integer; prc: PRECT; var pMargins: MARGINS): HRESULT; stdcall; SetWindowTheme: function(hwnd: HWND; pszSubAppName: LPCWSTR; pszSubIdList: LPCWSTR): HRESULT; stdcall; IsThemeActive: function: BOOL; stdcall; IsAppThemed: function: BOOL; stdcall; EnableTheming: function(fEnable: BOOL): HRESULT; stdcall; {$ENDIF} implementation {$IFDEF Windows} uses Messages, Forms, Classes; const UXTHEME_DLL = 'uxtheme.dll'; var DllHandle: THandle; procedure FreeXPThemes; begin if DllHandle <> 0 then begin if not IsLibrary then FreeLibrary(DllHandle); DllHandle := 0; OpenThemeData := nil; CloseThemeData := nil; DrawThemeBackground := nil; DrawThemeEdge := nil; GetThemeColor := nil; GetThemeMetric := nil; GetThemeMargins := nil; SetWindowTheme := nil; IsThemeActive := nil; IsAppThemed := nil; EnableTheming := nil; end; end; function InitXPThemes: Boolean; begin if DllHandle = 0 then begin DllHandle := LoadLibrary(UXTHEME_DLL); if DllHandle > 0 then begin OpenThemeData := GetProcAddress(DllHandle, 'OpenThemeData'); CloseThemeData := GetProcAddress(DllHandle, 'CloseThemeData'); DrawThemeBackground := GetProcAddress(DllHandle, 'DrawThemeBackground'); DrawThemeEdge := GetProcAddress(DllHandle, 'DrawThemeEdge'); GetThemeColor := GetProcAddress(DllHandle, 'GetThemeColor'); GetThemeMetric := GetProcAddress(DllHandle, 'GetThemeMetric'); GetThemeMargins := GetProcAddress(DllHandle, 'GetThemeMargins'); SetWindowTheme := GetProcAddress(DllHandle, 'SetWindowTheme'); IsThemeActive := GetProcAddress(DllHandle, 'IsThemeActive'); IsAppThemed := GetProcAddress(DllHandle, 'IsAppThemed'); EnableTheming := GetProcAddress(DllHandle, 'EnableTheming'); if (@OpenThemeData = nil) or (@CloseThemeData = nil) or (@IsThemeActive = nil) or (@IsAppThemed = nil) or (@EnableTheming = nil) then FreeXPThemes; end; end; Result := DllHandle > 0; end; function UseXPThemes: Boolean; begin Result := (DllHandle > 0) and IsAppThemed and IsThemeActive; end; type TThemeNexus = class private FWindowHandle: HWND; protected procedure WndProc(var Message: TMessage); procedure OpenVisualStyles; procedure CloseVisualStyles; public constructor Create; destructor Destroy; override; end; {$IFDEF SUPPORT_XPTHEMES} {$IFDEF XPTHEMES} var ThemeNexus: TThemeNexus; {$ENDIF} {$ENDIF} { TThemeNexus } constructor TThemeNexus.Create; begin FWindowHandle := Classes.AllocateHWnd(WndProc); OpenVisualStyles; end; destructor TThemeNexus.Destroy; begin CloseVisualStyles; Classes.DeallocateHWnd(FWindowHandle); inherited; end; procedure TThemeNexus.OpenVisualStyles; begin USE_THEMES := False; if InitXPThemes then begin USE_THEMES := UseXPThemes; if USE_THEMES then begin SCROLLBAR_THEME := OpenThemeData(FWindowHandle, 'SCROLLBAR'); GLOBALS_THEME := OpenThemeData(FWindowHandle, 'GLOBALS'); end; end; end; procedure TThemeNexus.CloseVisualStyles; begin if not IsLibrary and UseXPThemes then begin if SCROLLBAR_THEME <> 0 then begin CloseThemeData(SCROLLBAR_THEME); SCROLLBAR_THEME := 0; end; if GLOBALS_THEME <> 0 then begin CloseThemeData(GLOBALS_THEME); GLOBALS_THEME := 0; end; end; FreeXPThemes; end; procedure TThemeNexus.WndProc(var Message: TMessage); begin case Message.Msg of WM_THEMECHANGED: begin CloseVisualStyles; OpenVisualStyles; end; end; with Message do Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam); end; {$IFDEF SUPPORT_XPTHEMES} {$IFDEF XPTHEMES} initialization ThemeNexus := TThemeNexus.Create; finalization ThemeNexus.Free; {$ENDIF} {$ENDIF} {$ENDIF} end. |
Added src/graphics32/GR32_reg.lrs.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | LazarusResources.Add('TRangeBar','XPM',[ '/* XPM */'#13#10'static char *graphic[] = {'#13#10'"24 24 8 1",'#13#10'". c ' +'#FFFF00000000",'#13#10'", c #000000000000",'#13#10'"- c #C0DBC0DBC0DB",'#13 +#10'"* c #000000008092",'#13#10'"a c #A6B6CADBF0FF",'#13#10'"b c #00000000FF' +'FF",'#13#10'"c c #40490000C0DB",'#13#10'"d c #809280928092",'#13#10'"......' +'..................",'#13#10'"........................",'#13#10'"...........' +'.............",'#13#10'"........................",'#13#10'"................' +'........",'#13#10'"........................",'#13#10'".....................' +'...",'#13#10'"........................",'#13#10'"........................",' +#13#10'",,,,,*********,,,,,,,,,,",'#13#10'",----*aaaaaaa*dddd,----,",'#13#10 +'",-,,-*abbbbbc*dddd,-,,-,",'#13#10'",-,,-*abbbbbc*dddd,-,,-,",'#13#10'",---' +'-*acccccc*dddd,----,",'#13#10'",,,,,*********,,,,,,,,,,",'#13#10'".........' +'...............",'#13#10'"..,..................,..",'#13#10'".,............' +'........,.",'#13#10'",,,,,,,,,,,,,,,,,,,,,,,,",'#13#10'".,.................' +'...,.",'#13#10'"..,..................,..",'#13#10'"........................' +'",'#13#10'"........................",'#13#10'"........................"'#13 +#10'};'#13#10 ]); LazarusResources.Add('TBitmap32List','XPM',[ '/* XPM */'#13#10'static char *graphic[] = {'#13#10'"24 24 11 1",'#13#10'". c' +' #FFFFFFFFFFFF",'#13#10'", c #000000000000",'#13#10'"- c #202400000000",'#13 +#10'"* c #0000FFFFFFFF",'#13#10'"a c #00000000FFFF",'#13#10'"b c #0000FFFF00' +'00",'#13#10'"c c #FFFFFFFF0000",'#13#10'"d c #FFFF40490000",'#13#10'"e c #0' +'00020240000",'#13#10'"f c #000040490000",'#13#10'"g c #000080920000",'#13#10 +'"........................",'#13#10'"........................",'#13#10'"....' +',,,,,,,,,,,,,,,,,,,,",'#13#10'"....,******************,",'#13#10'"..,,,,,,,' +',,,,,,,,,,,,,*,",'#13#10'"..,******************,*,",'#13#10'",,,,,,,,,,,,,,' +',,,,,,*,*,",'#13#10'"-*******b*******b**,*,f,",'#13#10'",**cc**c,,**,,*****' +',*,f,",'#13#10'",*cccc****,***,****,g,f,",'#13#10'",*cccc*c,,***,*****,g,,,' +'",'#13#10'",**cc*****,*,*****g,g,e,",'#13#10'",*****c*,,**,,,*ggg,,,g,",'#13 +#10'",*c*c**********gggg,,,g,",'#13#10'",************gggf,f,f,g,",'#13#10'"-' +'aaaaaaa,aeefffffg,,f,g,",'#13#10'",aaabaaaaddffffffff,f,g,",'#13#10'",abaaa' +'aaaadd-ffffff,f,,,",'#13#10'",aaabbaaaaadd--ff,f,f,..",'#13#10'",bbaaaaaaaa' +'add---ff,,,..",'#13#10'",aabbabaaaaaadd---f,....",'#13#10'",,,,,,,,,,,,,,,,' +',,,,....",'#13#10'"........................",'#13#10'".....................' +'..."'#13#10'};'#13#10 ]); LazarusResources.Add('TGaugeBar','XPM',[ '/* XPM */'#13#10'static char *graphic[] = {'#13#10'"24 24 6 1",'#13#10'". c ' +'#FFFF00000000",'#13#10'", c #000000000000",'#13#10'"- c #C0DBC0DBC0DB",'#13 +#10'"* c #000000008092",'#13#10'"a c #00000000FFFF",'#13#10'"b c #8092809280' +'92",'#13#10'"........................",'#13#10'"........................",' +#13#10'"........................",'#13#10'"........................",'#13#10 +'"........................",'#13#10'"........................",'#13#10'"....' +'....................",'#13#10'"........................",'#13#10'".........' +'...............",'#13#10'",,,,,******,,,,,,,,,,,,,",'#13#10'",----*----*bbb' +'bbbb,----,",'#13#10'",-,,-*-aaa*bbbbbbb,-,,-,",'#13#10'",-,,-*-aaa*bbbbbbb,' +'-,,-,",'#13#10'",----*-aaa*bbbbbbb,----,",'#13#10'",,,,,******,,,,,,,,,,,,,' +'",'#13#10'"........................",'#13#10'"........................",'#13 +#10'"........................",'#13#10'"........................",'#13#10'".' +'.......................",'#13#10'"........................",'#13#10'"......' +'..................",'#13#10'"........................",'#13#10'"...........' +'............."'#13#10'};'#13#10 ]); LazarusResources.Add('TImage32','XPM',[ '/* XPM */'#13#10'static char *graphic[] = {'#13#10'"24 24 15 1",'#13#10'". c' +' #FFFFFFFFFFFF",'#13#10'", c #000000000000",'#13#10'"- c #000040490000",'#13 +#10'"* c #0000FFFFFFFF",'#13#10'"a c #0000606DC0DB",'#13#10'"b c #00000000FF' +'FF",'#13#10'"c c #606DE0FF0000",'#13#10'"d c #FFFFFFFF0000",'#13#10'"e c #E' +'0FF80920000",'#13#10'"f c #00004049C0DB",'#13#10'"g c #000080920000",'#13#10 +'"h c #4049606D0000",'#13#10'"i c #404940490000",'#13#10'"j c #606D20240000"' +','#13#10'"k c #202480920000",'#13#10'"........................",'#13#10'"..' +'......................",'#13#10'",,,,,,,,,,,,,,,,,,,,,,,,",'#13#10'",******' +'****************,",'#13#10'",**dd**d**,,***,,******,",'#13#10'",*dddd***,**' +',*,**,*****,",'#13#10'",*dddd*d***,*****,*****,",'#13#10'"-**dd***a***,***-' +'******,",'#13#10'",*****d**,**,**,*******,",'#13#10'",*d*d*****,,**,,,,***g' +',,",'#13#10'",******************gg-k,",'#13#10'",****************gghh-,,",' +#13#10'",**************gghhh--,,",'#13#10'",aaaaaaaaaaaagghhhh---k,",'#13#10 +'",bbcbbbbbbbbeehhhhh-k-k,",'#13#10'"-bbbcbbbbbbbeehhhh----,,",'#13#10'",bcb' +'bbbbbbbbfeeihh---k,,",'#13#10'",bbbccbbbbbbbfeej-----k,",'#13#10'",ccbbbbbb' +'bbbbbfeejjj-k,,",'#13#10'",bbccbcbbbbbbbffeejjj,k,",'#13#10'",bbbbbbbbbbbbb' +'bbbeeejjj,",'#13#10'",,,,,,,,,,,,,,,,,,,,,,,,",'#13#10'"...................' +'.....",'#13#10'"........................"'#13#10'};'#13#10 ]); LazarusResources.Add('TImgView32','XPM',[ '/* XPM */'#13#10'static char *graphic[] = {'#13#10'"24 24 10 1",'#13#10'". c' +' #809200000000",'#13#10'", c #000000000000",'#13#10'"- c #0000FFFFFFFF",'#13 +#10'"* c #000080928092",'#13#10'"a c #00000000FFFF",'#13#10'"b c #FFFFFFFFFF' +'FF",'#13#10'"c c #FFFFFFFF0000",'#13#10'"d c #0000FFFF0000",'#13#10'"e c #8' +'09280920000",'#13#10'"f c #000080920000",'#13#10'"........................"' +','#13#10'"........................",'#13#10'",,,,,,,,,,,,,,,,,,,,,,,,",'#13 +#10'",------------------,bbb,",'#13#10'",--cc--c--,,---,,--,b,b,",'#13#10'",' +'-cccc---,--,-,--,-,bbb,",'#13#10'",-cccc-c---,-----,-,,,,,",'#13#10'".--cc-' +'--*---,---.--,bbb,",'#13#10'",-----c--,--,--,---,bbb,",'#13#10'",-c-c-----,' +',--,,,,-,bbb,",'#13#10'",------------------,bbb,",'#13#10'",---------------' +'-ff,bbb,",'#13#10'",--------------ffff,bbb,",'#13#10'",************ffffff,b' +'bb,",'#13#10'",aadaaaaaaaaeefffff,bbb,",'#13#10'".aaadaaaaaaaeeffff,,bbb,",' +#13#10'",adaaaaaaaaaaee,ff,,bbb,",'#13#10'",,,,,,,,,,,,,,,,,,,,,,,,",'#13#10 +'",bbb,bbbbbbbbbbbbbb,bbb,",'#13#10'",b,b,bbbbbbbbbbbbbb,b,b,",'#13#10'",bbb' +',bbbbbbbbbbbbbb,bbb,",'#13#10'",,,,,,,,,,,,,,,,,,,,,,,,",'#13#10'".........' +'...............",'#13#10'"........................"'#13#10'};'#13#10 ]); LazarusResources.Add('TPaintBox32','XPM',[ '/* XPM */'#13#10'static char *graphic[] = {'#13#10'"24 24 9 1",'#13#10'". c ' +'#C0DBC0DBC0DB",'#13#10'", c #FFFFFFFFFFFF",'#13#10'"- c #809280928092",'#13 +#10'"* c #000000000000",'#13#10'"a c #FFFFFFFF0000",'#13#10'"b c #0000FFFFFF' +'FF",'#13#10'"c c #00000000FFFF",'#13#10'"d c #0000FFFF0000",'#13#10'"e c #0' +'00080920000",'#13#10'"........................",'#13#10'"..................' +'......",'#13#10'"........................",'#13#10'".......................' +'.",'#13#10'".,,,,,,,,,,,,,,,,,,,,,..",'#13#10'".,.........,*,*,*,*,*.-.",' +#13#10'".,.........*aabbbbbd,.-.",'#13#10'".,.........,aabbbbde*.-.",'#13#10 +'".,.........*bbbbbdee,.-.",'#13#10'".,.........,ccccaeee*.-.",'#13#10'".,..' +'.......*ccccaaee,.-.",'#13#10'".,.........,cccccaae*.-.",'#13#10'".,.......' +'..*,*,*,*,*,.-.",'#13#10'".,.**..**.............-.",'#13#10'".,...*...*....' +'........-.",'#13#10'".,.**...*.............-.",'#13#10'".,...*.*...........' +'...-.",'#13#10'".,.**..***............-.",'#13#10'".,....................-.' +'",'#13#10'"..---------------------.",'#13#10'"........................",'#13 +#10'"........................",'#13#10'"........................",'#13#10'".' +'......................."'#13#10'};'#13#10 ]); LazarusResources.Add('TSyntheticImage32','XPM',[ '/* XPM */'#13#10'static char *graphic[] = {'#13#10'"24 24 30 1",'#13#10'". c' +' #FFFF0000FFFF",'#13#10'", c #000000000000",'#13#10'"- c #4049C0DB0000",'#13 +#10'"* c #4049C0DB4049",'#13#10'"a c #606DE0FF4049",'#13#10'"b c #2024E0FF40' +'49",'#13#10'"c c #8092E0FF4049",'#13#10'"d c #A0B6E0FF4049",'#13#10'"e c #F' +'FFFFBFFF0FF",'#13#10'"f c #A0B6C0DB8092",'#13#10'"g c #606D606D4049",'#13#10 +'"h c #8092A0B68092",'#13#10'"i c #4049E0FF4049",'#13#10'"j c #606DE0FF0000"' +','#13#10'"k c #809280928092",'#13#10'"l c #A0B6A0B6A4B6",'#13#10'"m c #FFFF' +'FFFFFFFF",'#13#10'"n c #A0B6E0FF8092",'#13#10'"o c #C0DBDCDBC0DB",'#13#10'"' +'p c #000040490000",'#13#10'"q c #C0DBC0DBC0DB",'#13#10'"r c #202440490000",' +#13#10'"s c #C0DBE0FF8092",'#13#10'"t c #4049606D4049",'#13#10'"u c #0000E0F' +'F4049",'#13#10'"v c #2024606D0000",'#13#10'"w c #8092E0FF8092",'#13#10'"x c' +' #4049A0B64049",'#13#10'"y c #202420244049",'#13#10'"z c #A0B6C0DBC0DB",'#13 +#10'"........................",'#13#10'"........................",'#13#10'",' +',,,,,,,,,,,,,,,,,,,,,,,",'#13#10'",----*boesui*---------a,",'#13#10'",---in' +'elrmnnai---------,",'#13#10'",--ajeeketmejwa--------,",'#13#10'",--ceopqmtv' +'lmscn*------,",'#13#10'",-beklmmmmekrmmncw-----,",'#13#10'",-cflmmmmmmmkxmm' +'menc*--,",'#13#10'",*dgmmmmmmmmmppggymowa*,",'#13#10'",acgemmmmmmmmlemmkrmm' +'cn,",'#13#10'",aahleemmmmmmmmmmmqtzoo,",'#13#10'",aahleemmmmmmmmmmmqtzoo,",' +#13#10'",acgemmmmmmmmlemmkrmmcn,",'#13#10'",*dgmmmmmmmmmppggymowa*,",'#13#10 +'",-cflmmmmmmmkxmmmenc*--,",'#13#10'",-beklmmmmekrmmncw-----,",'#13#10'",--c' +'eopqmtvlmscn*------,",'#13#10'",--ajeeketmejwa--------,",'#13#10'",---inelr' +'mnnai---------,",'#13#10'",----*boesui*---------a,",'#13#10'",,,,,,,,,,,,,,' +',,,,,,,,,,",'#13#10'"........................",'#13#10'"...................' +'....."'#13#10'};'#13#10 ]); |
Added src/graphics32/License.txt.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 | LICENSE ------- Graphics32 is licensed under the Mozilla Public License (MPL) 1.1 and the Lesser General Public License (LGPL) 2.1 with linking exception. You may use the files in this distribution under the terms of either the MPL 1.1 or the LGPL 2.1 with linking exception (see below). MOZILLA PUBLIC LICENSE Version 1.1 --------------- 1. Definitions. 1.0.1. "Commercial Use" means distribution or otherwise making the Covered Code available to a third party. 1.1. "Contributor" means each entity that creates or contributes to the creation of Modifications. 1.2. "Contributor Version" means the combination of the Original Code, prior Modifications used by a Contributor, and the Modifications made by that particular Contributor. 1.3. "Covered Code" means the Original Code or Modifications or the combination of the Original Code and Modifications, in each case including portions thereof. 1.4. "Electronic Distribution Mechanism" means a mechanism generally accepted in the software development community for the electronic transfer of data. 1.5. "Executable" means Covered Code in any form other than Source Code. 1.6. "Initial Developer" means the individual or entity identified as the Initial Developer in the Source Code notice required by Exhibit A. 1.7. "Larger Work" means a work which combines Covered Code or portions thereof with code not governed by the terms of this License. 1.8. "License" means this document. 1.8.1. "Licensable" means having the right to grant, to the maximum extent possible, whether at the time of the initial grant or subsequently acquired, any and all of the rights conveyed herein. 1.9. "Modifications" means any addition to or deletion from the substance or structure of either the Original Code or any previous Modifications. When Covered Code is released as a series of files, a Modification is: A. Any addition to or deletion from the contents of a file containing Original Code or previous Modifications. B. Any new file that contains any part of the Original Code or previous Modifications. 1.10. "Original Code" means Source Code of computer software code which is described in the Source Code notice required by Exhibit A as Original Code, and which, at the time of its release under this License is not already Covered Code governed by this License. 1.10.1. "Patent Claims" means any patent claim(s), now owned or hereafter acquired, including without limitation, method, process, and apparatus claims, in any patent Licensable by grantor. 1.11. "Source Code" means the preferred form of the Covered Code for making modifications to it, including all modules it contains, plus any associated interface definition files, scripts used to control compilation and installation of an Executable, or source code differential comparisons against either the Original Code or another well known, available Covered Code of the Contributor's choice. The Source Code can be in a compressed or archival form, provided the appropriate decompression or de-archiving software is widely available for no charge. 1.12. "You" (or "Your") means an individual or a legal entity exercising rights under, and complying with all of the terms of, this License or a future version of this License issued under Section 6.1. For legal entities, "You" includes any entity which controls, is controlled by, or is under common control with You. For purposes of this definition, "control" means (a) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (b) ownership of more than fifty percent (50%) of the outstanding shares or beneficial ownership of such entity. 2. Source Code License. 2.1. The Initial Developer Grant. The Initial Developer hereby grants You a world-wide, royalty-free, non-exclusive license, subject to third party intellectual property claims: (a) under intellectual property rights (other than patent or trademark) Licensable by Initial Developer to use, reproduce, modify, display, perform, sublicense and distribute the Original Code (or portions thereof) with or without Modifications, and/or as part of a Larger Work; and (b) under Patents Claims infringed by the making, using or selling of Original Code, to make, have made, use, practice, sell, and offer for sale, and/or otherwise dispose of the Original Code (or portions thereof). (c) the licenses granted in this Section 2.1(a) and (b) are effective on the date Initial Developer first distributes Original Code under the terms of this License. (d) Notwithstanding Section 2.1(b) above, no patent license is granted: 1) for code that You delete from the Original Code; 2) separate from the Original Code; or 3) for infringements caused by: i) the modification of the Original Code or ii) the combination of the Original Code with other software or devices. 2.2. Contributor Grant. Subject to third party intellectual property claims, each Contributor hereby grants You a world-wide, royalty-free, non-exclusive license (a) under intellectual property rights (other than patent or trademark) Licensable by Contributor, to use, reproduce, modify, display, perform, sublicense and distribute the Modifications created by such Contributor (or portions thereof) either on an unmodified basis, with other Modifications, as Covered Code and/or as part of a Larger Work; and (b) under Patent Claims infringed by the making, using, or selling of Modifications made by that Contributor either alone and/or in combination with its Contributor Version (or portions of such combination), to make, use, sell, offer for sale, have made, and/or otherwise dispose of: 1) Modifications made by that Contributor (or portions thereof); and 2) the combination of Modifications made by that Contributor with its Contributor Version (or portions of such combination). (c) the licenses granted in Sections 2.2(a) and 2.2(b) are effective on the date Contributor first makes Commercial Use of the Covered Code. (d) Notwithstanding Section 2.2(b) above, no patent license is granted: 1) for any code that Contributor has deleted from the Contributor Version; 2) separate from the Contributor Version; 3) for infringements caused by: i) third party modifications of Contributor Version or ii) the combination of Modifications made by that Contributor with other software (except as part of the Contributor Version) or other devices; or 4) under Patent Claims infringed by Covered Code in the absence of Modifications made by that Contributor. 3. Distribution Obligations. 3.1. Application of License. The Modifications which You create or to which You contribute are governed by the terms of this License, including without limitation Section 2.2. The Source Code version of Covered Code may be distributed only under the terms of this License or a future version of this License released under Section 6.1, and You must include a copy of this License with every copy of the Source Code You distribute. You may not offer or impose any terms on any Source Code version that alters or restricts the applicable version of this License or the recipients' rights hereunder. However, You may include an additional document offering the additional rights described in Section 3.5. 3.2. Availability of Source Code. Any Modification which You create or to which You contribute must be made available in Source Code form under the terms of this License either on the same media as an Executable version or via an accepted Electronic Distribution Mechanism to anyone to whom you made an Executable version available; and if made available via Electronic Distribution Mechanism, must remain available for at least twelve (12) months after the date it initially became available, or at least six (6) months after a subsequent version of that particular Modification has been made available to such recipients. You are responsible for ensuring that the Source Code version remains available even if the Electronic Distribution Mechanism is maintained by a third party. 3.3. Description of Modifications. You must cause all Covered Code to which You contribute to contain a file documenting the changes You made to create that Covered Code and the date of any change. You must include a prominent statement that the Modification is derived, directly or indirectly, from Original Code provided by the Initial Developer and including the name of the Initial Developer in (a) the Source Code, and (b) in any notice in an Executable version or related documentation in which You describe the origin or ownership of the Covered Code. 3.4. Intellectual Property Matters (a) Third Party Claims. If Contributor has knowledge that a license under a third party's intellectual property rights is required to exercise the rights granted by such Contributor under Sections 2.1 or 2.2, Contributor must include a text file with the Source Code distribution titled "LEGAL" which describes the claim and the party making the claim in sufficient detail that a recipient will know whom to contact. If Contributor obtains such knowledge after the Modification is made available as described in Section 3.2, Contributor shall promptly modify the LEGAL file in all copies Contributor makes available thereafter and shall take other steps (such as notifying appropriate mailing lists or newsgroups) reasonably calculated to inform those who received the Covered Code that new knowledge has been obtained. (b) Contributor APIs. If Contributor's Modifications include an application programming interface and Contributor has knowledge of patent licenses which are reasonably necessary to implement that API, Contributor must also include this information in the LEGAL file. (c) Representations. Contributor represents that, except as disclosed pursuant to Section 3.4(a) above, Contributor believes that Contributor's Modifications are Contributor's original creation(s) and/or Contributor has sufficient rights to grant the rights conveyed by this License. 3.5. Required Notices. You must duplicate the notice in Exhibit A in each file of the Source Code. If it is not possible to put such notice in a particular Source Code file due to its structure, then You must include such notice in a location (such as a relevant directory) where a user would be likely to look for such a notice. If You created one or more Modification(s) You may add your name as a Contributor to the notice described in Exhibit A. You must also duplicate this License in any documentation for the Source Code where You describe recipients' rights or ownership rights relating to Covered Code. You may choose to offer, and to charge a fee for, warranty, support, indemnity or liability obligations to one or more recipients of Covered Code. However, You may do so only on Your own behalf, and not on behalf of the Initial Developer or any Contributor. You must make it absolutely clear than any such warranty, support, indemnity or liability obligation is offered by You alone, and You hereby agree to indemnify the Initial Developer and every Contributor for any liability incurred by the Initial Developer or such Contributor as a result of warranty, support, indemnity or liability terms You offer. 3.6. Distribution of Executable Versions. You may distribute Covered Code in Executable form only if the requirements of Section 3.1-3.5 have been met for that Covered Code, and if You include a notice stating that the Source Code version of the Covered Code is available under the terms of this License, including a description of how and where You have fulfilled the obligations of Section 3.2. The notice must be conspicuously included in any notice in an Executable version, related documentation or collateral in which You describe recipients' rights relating to the Covered Code. You may distribute the Executable version of Covered Code or ownership rights under a license of Your choice, which may contain terms different from this License, provided that You are in compliance with the terms of this License and that the license for the Executable version does not attempt to limit or alter the recipient's rights in the Source Code version from the rights set forth in this License. If You distribute the Executable version under a different license You must make it absolutely clear that any terms which differ from this License are offered by You alone, not by the Initial Developer or any Contributor. You hereby agree to indemnify the Initial Developer and every Contributor for any liability incurred by the Initial Developer or such Contributor as a result of any such terms You offer. 3.7. Larger Works. You may create a Larger Work by combining Covered Code with other code not governed by the terms of this License and distribute the Larger Work as a single product. In such a case, You must make sure the requirements of this License are fulfilled for the Covered Code. 4. Inability to Comply Due to Statute or Regulation. If it is impossible for You to comply with any of the terms of this License with respect to some or all of the Covered Code due to statute, judicial order, or regulation then You must: (a) comply with the terms of this License to the maximum extent possible; and (b) describe the limitations and the code they affect. Such description must be included in the LEGAL file described in Section 3.4 and must be included with all distributions of the Source Code. Except to the extent prohibited by statute or regulation, such description must be sufficiently detailed for a recipient of ordinary skill to be able to understand it. 5. Application of this License. This License applies to code to which the Initial Developer has attached the notice in Exhibit A and to related Covered Code. 6. Versions of the License. 6.1. New Versions. Netscape Communications Corporation ("Netscape") may publish revised and/or new versions of the License from time to time. Each version will be given a distinguishing version number. 6.2. Effect of New Versions. Once Covered Code has been published under a particular version of the License, You may always continue to use it under the terms of that version. You may also choose to use such Covered Code under the terms of any subsequent version of the License published by Netscape. No one other than Netscape has the right to modify the terms applicable to Covered Code created under this License. 6.3. Derivative Works. If You create or use a modified version of this License (which you may only do in order to apply it to code which is not already Covered Code governed by this License), You must (a) rename Your license so that the phrases "Mozilla", "MOZILLAPL", "MOZPL", "Netscape", "MPL", "NPL" or any confusingly similar phrase do not appear in your license (except to note that your license differs from this License) and (b) otherwise make it clear that Your version of the license contains terms which differ from the Mozilla Public License and Netscape Public License. (Filling in the name of the Initial Developer, Original Code or Contributor in the notice described in Exhibit A shall not of themselves be deemed to be modifications of this License.) 7. DISCLAIMER OF WARRANTY. COVERED CODE IS PROVIDED UNDER THIS LICENSE ON AN "AS IS" BASIS, WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, WITHOUT LIMITATION, WARRANTIES THAT THE COVERED CODE IS FREE OF DEFECTS, MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE OR NON-INFRINGING. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE COVERED CODE IS WITH YOU. SHOULD ANY COVERED CODE PROVE DEFECTIVE IN ANY RESPECT, YOU (NOT THE INITIAL DEVELOPER OR ANY OTHER CONTRIBUTOR) ASSUME THE COST OF ANY NECESSARY SERVICING, REPAIR OR CORRECTION. THIS DISCLAIMER OF WARRANTY CONSTITUTES AN ESSENTIAL PART OF THIS LICENSE. NO USE OF ANY COVERED CODE IS AUTHORIZED HEREUNDER EXCEPT UNDER THIS DISCLAIMER. 8. TERMINATION. 8.1. This License and the rights granted hereunder will terminate automatically if You fail to comply with terms herein and fail to cure such breach within 30 days of becoming aware of the breach. All sublicenses to the Covered Code which are properly granted shall survive any termination of this License. Provisions which, by their nature, must remain in effect beyond the termination of this License shall survive. 8.2. If You initiate litigation by asserting a patent infringement claim (excluding declatory judgment actions) against Initial Developer or a Contributor (the Initial Developer or Contributor against whom You file such action is referred to as "Participant") alleging that: (a) such Participant's Contributor Version directly or indirectly infringes any patent, then any and all rights granted by such Participant to You under Sections 2.1 and/or 2.2 of this License shall, upon 60 days notice from Participant terminate prospectively, unless if within 60 days after receipt of notice You either: (i) agree in writing to pay Participant a mutually agreeable reasonable royalty for Your past and future use of Modifications made by such Participant, or (ii) withdraw Your litigation claim with respect to the Contributor Version against such Participant. If within 60 days of notice, a reasonable royalty and payment arrangement are not mutually agreed upon in writing by the parties or the litigation claim is not withdrawn, the rights granted by Participant to You under Sections 2.1 and/or 2.2 automatically terminate at the expiration of the 60 day notice period specified above. (b) any software, hardware, or device, other than such Participant's Contributor Version, directly or indirectly infringes any patent, then any rights granted to You by such Participant under Sections 2.1(b) and 2.2(b) are revoked effective as of the date You first made, used, sold, distributed, or had made, Modifications made by that Participant. 8.3. If You assert a patent infringement claim against Participant alleging that such Participant's Contributor Version directly or indirectly infringes any patent where such claim is resolved (such as by license or settlement) prior to the initiation of patent infringement litigation, then the reasonable value of the licenses granted by such Participant under Sections 2.1 or 2.2 shall be taken into account in determining the amount or value of any payment or license. 8.4. In the event of termination under Sections 8.1 or 8.2 above, all end user license agreements (excluding distributors and resellers) which have been validly granted by You or any distributor hereunder prior to termination shall survive termination. 9. LIMITATION OF LIABILITY. UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, WHETHER TORT (INCLUDING NEGLIGENCE), CONTRACT, OR OTHERWISE, SHALL YOU, THE INITIAL DEVELOPER, ANY OTHER CONTRIBUTOR, OR ANY DISTRIBUTOR OF COVERED CODE, OR ANY SUPPLIER OF ANY OF SUCH PARTIES, BE LIABLE TO ANY PERSON FOR ANY INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES OF ANY CHARACTER INCLUDING, WITHOUT LIMITATION, DAMAGES FOR LOSS OF GOODWILL, WORK STOPPAGE, COMPUTER FAILURE OR MALFUNCTION, OR ANY AND ALL OTHER COMMERCIAL DAMAGES OR LOSSES, EVEN IF SUCH PARTY SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF SUCH DAMAGES. THIS LIMITATION OF LIABILITY SHALL NOT APPLY TO LIABILITY FOR DEATH OR PERSONAL INJURY RESULTING FROM SUCH PARTY'S NEGLIGENCE TO THE EXTENT APPLICABLE LAW PROHIBITS SUCH LIMITATION. SOME JURISDICTIONS DO NOT ALLOW THE EXCLUSION OR LIMITATION OF INCIDENTAL OR CONSEQUENTIAL DAMAGES, SO THIS EXCLUSION AND LIMITATION MAY NOT APPLY TO YOU. 10. U.S. GOVERNMENT END USERS. The Covered Code is a "commercial item," as that term is defined in 48 C.F.R. 2.101 (Oct. 1995), consisting of "commercial computer software" and "commercial computer software documentation," as such terms are used in 48 C.F.R. 12.212 (Sept. 1995). Consistent with 48 C.F.R. 12.212 and 48 C.F.R. 227.7202-1 through 227.7202-4 (June 1995), all U.S. Government End Users acquire Covered Code with only those rights set forth herein. 11. MISCELLANEOUS. This License represents the complete agreement concerning subject matter hereof. If any provision of this License is held to be unenforceable, such provision shall be reformed only to the extent necessary to make it enforceable. This License shall be governed by California law provisions (except to the extent applicable law, if any, provides otherwise), excluding its conflict-of-law provisions. With respect to disputes in which at least one party is a citizen of, or an entity chartered or registered to do business in the United States of America, any litigation relating to this License shall be subject to the jurisdiction of the Federal Courts of the Northern District of California, with venue lying in Santa Clara County, California, with the losing party responsible for costs, including without limitation, court costs and reasonable attorneys' fees and expenses. The application of the United Nations Convention on Contracts for the International Sale of Goods is expressly excluded. Any law or regulation which provides that the language of a contract shall be construed against the drafter shall not apply to this License. 12. RESPONSIBILITY FOR CLAIMS. As between Initial Developer and the Contributors, each party is responsible for claims and damages arising, directly or indirectly, out of its utilization of rights under this License and You agree to work with Initial Developer and Contributors to distribute such responsibility on an equitable basis. Nothing herein is intended or shall be deemed to constitute any admission of liability. 13. MULTIPLE-LICENSED CODE. Initial Developer may designate portions of the Covered Code as "Multiple-Licensed". "Multiple-Licensed" means that the Initial Developer permits you to utilize portions of the Covered Code under Your choice of the NPL or the alternative licenses, if any, specified by the Initial Developer in the file described in Exhibit A. EXHIBIT A -Mozilla Public License. ``The contents of this file are 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/ 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. The Original Code is ______________________________________. The Initial Developer of the Original Code is ________________________. Portions created by ______________________ are Copyright (C) ______ _______________________. All Rights Reserved. Contributor(s): ______________________________________. Alternatively, the contents of this file may be used under the terms of the _____ license (the "[___] License"), in which case the provisions of [______] License are applicable instead of those above. If you wish to allow use of your version of this file only under the terms of the [____] License and not to allow others to use your version of this file under the MPL, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the [___] License. If you do not delete the provisions above, a recipient may use your version of this file under either the MPL or the [___] License." [NOTE: The text of this Exhibit A may differ slightly from the text of the notices in the Source Code files of the Original Code. You should use the text of this Exhibit A rather than the text found in the Original Code Source Code for Your Modifications.] ----------------------------------------------------------------------------- GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. <one line to give the library's name and a brief idea of what it does.> Copyright (C) <year> <name of author> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. <signature of Ty Coon>, 1 April 1990 Ty Coon, President of Vice That's all there is to it! LINKING EXCEPTION FOR THE LESSER GENERAL PUBLIC LICENSE 2.1 As a special exception, the copyright holders of this library give you permission to link this library with independent modules to produce an executable, regardless of the license terms of these independent modules, and to copy and distribute the resulting executable under terms of your choice, provided that you also meet, for each linked independent module, the terms and conditions of the license of that module. An independent module is a module which is not derived from or based on this library. If you modify this library, you may extend this exception to your version of the library, but you are not obligated to do so. If you do not wish to do so, delete this exception statement from your version. |
Added src/graphics32/Packages/2010/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/2010/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX '2010'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/2010/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>2010</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/2010/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | package GR32_R; {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX '2010'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/2010/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>2010</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/GR32_CB6.bpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | <?xml version='1.0' encoding='utf-8' ?> <!-- C++Builder XML Project --> <PROJECT> <MACROS> <VERSION value="BCB.06.00"/> <PROJECT value="GR32_CB6.bpl"/> <OBJFILES value="GR32_CB6.obj ..\GR32.obj ..\GR32_Blend.obj ..\GR32_System.obj ..\GR32_DrawingEx.obj ..\GR32_Filters.obj ..\GR32_Image.obj ..\GR32_Layers.obj ..\GR32_LowLevel.obj ..\GR32_Polygons.obj ..\GR32_RangeBars.obj ..\GR32_Transforms.obj ..\GR32_OrdinalMaps.obj ..\GR32_Resamplers.obj ..\GR32_VectorMaps.obj ..\GR32_Containers.obj ..\GR32_MicroTiles.obj ..\GR32_Rasterizers.obj ..\GR32_RepaintOpt.obj ..\GR32_ExtImage.obj"/> <RESFILES value="GR32_CB6.res"/> <IDLFILES value=""/> <IDLGENFILES value=""/> <DEFFILE value=""/> <RESDEPEN value="$(RESFILES)"/> <LIBFILES value=""/> <LIBRARIES value=""/> <SPARELIBS value="rtl.lib"/> <PACKAGES value="rtl.bpi vcl.bpi"/> <PATHCPP value=".;"/> <PATHPAS value=".;..;..;..;..;..;..;..;..;..;..;..;..;..;..;..;..;..;..;.."/> <PATHRC value=".;"/> <PATHASM value=".;"/> <DEBUGLIBPATH value="$(BCB)\lib\debug"/> <RELEASELIBPATH value="$(BCB)\lib\release"/> <LINKER value="ilink32"/> <USERDEFINES value="_DEBUG"/> <SYSDEFINES value="_RTLDLL;NO_STRICT;USEPACKAGES"/> <MAINSOURCE value="GR32_CB6.cpp"/> <INCLUDEPATH value="..\;..;$(BCB)\include;$(BCB)\include\vcl"/> <LIBPATH value="..\;..;$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib"/> <WARNINGS value="-w-par"/> <OTHERFILES value=""/> </MACROS> <OPTIONS> <IDLCFLAGS value="-I..\. -I.. -I$(BCB)\include -I$(BCB)\include\vcl -src_suffix cpp -D_DEBUG -boa"/> <CFLAG1 value="-Od -H=$(BCB)\lib\vcl60.csm -Hc -Vx -Ve -X- -r- -a8 -b- -k -y -v -vi- -c -tWM"/> <PFLAGS value="-$YD -$W -$O- -$A8 -v -JPHNE -M"/> <RFLAGS value=""/> <AFLAGS value="/mx /w2 /zd"/> <LFLAGS value="-D"Graphics32" -aa -Tpp -x -Gn -Gl -Gi -v"/> <OTHERFILES value=""/> </OPTIONS> <LINKER> <ALLOBJ value="c0pkg32.obj $(PACKAGES) Memmgr.Lib sysinit.obj $(OBJFILES)"/> <ALLRES value="$(RESFILES)"/> <ALLLIB value="$(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib"/> <OTHERFILES value=""/> </LINKER> <FILELIST> <FILE FILENAME="GR32_CB6.cpp" FORMNAME="" UNITNAME="GR32_CB6" CONTAINERID="CCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="GR32_CB6.res" FORMNAME="" UNITNAME="GR32_CB6.res" CONTAINERID="ResTool" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32.pas" FORMNAME="" UNITNAME="GR32" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Blend.pas" FORMNAME="" UNITNAME="GR32_Blend" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_System.pas" FORMNAME="" UNITNAME="GR32_System" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_DrawingEx.pas" FORMNAME="" UNITNAME="GR32_DrawingEx" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Filters.pas" FORMNAME="" UNITNAME="GR32_Filters" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Image.pas" FORMNAME="" UNITNAME="GR32_Image" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Layers.pas" FORMNAME="" UNITNAME="GR32_Layers" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_LowLevel.pas" FORMNAME="" UNITNAME="GR32_LowLevel" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Polygons.pas" FORMNAME="" UNITNAME="GR32_Polygons" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_RangeBars.pas" FORMNAME="" UNITNAME="GR32_RangeBars" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Transforms.pas" FORMNAME="" UNITNAME="GR32_Transforms" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\..\..\rtl.bpi" FORMNAME="" UNITNAME="rtl" CONTAINERID="BPITool" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\..\..\vcl.bpi" FORMNAME="" UNITNAME="vcl" CONTAINERID="BPITool" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_OrdinalMaps.pas" FORMNAME="" UNITNAME="GR32_OrdinalMaps" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Resamplers.pas" FORMNAME="" UNITNAME="GR32_Resamplers" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_VectorMaps.pas" FORMNAME="" UNITNAME="GR32_VectorMaps" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Containers.pas" FORMNAME="" UNITNAME="GR32_Containers" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_MicroTiles.pas" FORMNAME="" UNITNAME="GR32_MicroTiles" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Rasterizers.pas" FORMNAME="" UNITNAME="GR32_Rasterizers" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_RepaintOpt.pas" FORMNAME="" UNITNAME="GR32_RepaintOpt" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_ExtImage.pas" FORMNAME="" UNITNAME="GR32_ExtImage" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> </FILELIST> <BUILDTOOLS> </BUILDTOOLS> <IDEOPTIONS> [Version Info] IncludeVerInfo=0 AutoIncBuild=0 MajorVer=1 MinorVer=0 Release=0 Build=0 Debug=0 PreRelease=0 Special=0 Private=0 DLL=0 Locale=1031 CodePage=1252 [Debugging] DebugSourceDirs= [Parameters] RunParams= Launcher= UseLauncher=0 DebugCWD= HostApplication= RemoteHost= RemotePath= RemoteLauncher= RemoteCWD= RemoteDebug=0 [Compiler] ShowInfoMsgs=0 LinkDebugVcl=0 LinkCGLIB=0 [CORBA] AddServerUnit=1 AddClientUnit=1 PrecompiledHeaders=1 [Language] ActiveLang= ProjectLang= RootDir= [Linker] LibPrefix= LibSuffix= LibVersion= </IDEOPTIONS> </PROJECT> |
Added src/graphics32/Packages/GR32_CB6.cpp.
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | //--------------------------------------------------------------------------- #include <vcl.h> #pragma hdrstop #pragma package(smart_init) //--------------------------------------------------------------------------- // Package source. //--------------------------------------------------------------------------- #pragma argsused int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) { return 1; } //--------------------------------------------------------------------------- |
Added src/graphics32/Packages/GR32_CB6.res.
cannot compute difference between binary files
Added src/graphics32/Packages/GR32_D2005.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | package GR32_D2005; {$R *.res} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32'} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\GR32.pas', GR32_Bindings in '..\GR32_Bindings.pas', GR32_Math in '..\GR32_Math.pas', GR32_LowLevel in '..\GR32_LowLevel.pas', GR32_System in '..\GR32_System.pas', GR32_Containers in '..\GR32_Containers.pas', GR32_Blend in '..\GR32_Blend.pas', GR32_Transforms in '..\GR32_Transforms.pas', GR32_OrdinalMaps in '..\GR32_OrdinalMaps.pas', GR32_VectorMaps in '..\GR32_VectorMaps.pas', GR32_Filters in '..\GR32_Filters.pas', GR32_Layers in '..\GR32_Layers.pas', GR32_Image in '..\GR32_Image.pas', GR32_ExtImage in '..\GR32_ExtImage.pas', GR32_RangeBars in '..\GR32_RangeBars.pas', GR32_Polygons in '..\GR32_Polygons.pas', GR32_RepaintOpt in '..\GR32_RepaintOpt.pas', GR32_MicroTiles in '..\GR32_MicroTiles.pas', GR32_Rasterizers in '..\GR32_Rasterizers.pas', GR32_Resamplers in '..\GR32_Resamplers.pas', GR32_Backends in '..\GR32_Backends.pas', GR32_Backends_Generic in '..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\GR32_Backends_VCL.pas', GR32_XPThemes in '..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/GR32_D7.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | package GR32_D7; {$R *.res} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl, rtl; contains GR32 in '..\GR32.pas', GR32_Bindings in '..\GR32_Bindings.pas', GR32_Math in '..\GR32_Math.pas', GR32_LowLevel in '..\GR32_LowLevel.pas', GR32_System in '..\GR32_System.pas', GR32_Containers in '..\GR32_Containers.pas', GR32_Blend in '..\GR32_Blend.pas', GR32_Transforms in '..\GR32_Transforms.pas', GR32_OrdinalMaps in '..\GR32_OrdinalMaps.pas', GR32_VectorMaps in '..\GR32_VectorMaps.pas', GR32_Filters in '..\GR32_Filters.pas', GR32_Layers in '..\GR32_Layers.pas', GR32_Image in '..\GR32_Image.pas', GR32_ExtImage in '..\GR32_ExtImage.pas', GR32_RangeBars in '..\GR32_RangeBars.pas', GR32_Polygons in '..\GR32_Polygons.pas', GR32_RepaintOpt in '..\GR32_RepaintOpt.pas', GR32_MicroTiles in '..\GR32_MicroTiles.pas', GR32_Rasterizers in '..\GR32_Rasterizers.pas', GR32_Resamplers in '..\GR32_Resamplers.pas', GR32_Backends in '..\GR32_Backends.pas', GR32_Backends_Generic in '..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\GR32_Backends_VCL.pas', GR32_XPThemes in '..\GR32_XPThemes.pas', GR32_VPR in '..\GR32_VPR.pas', GR32_Paths in '..\GR32_Paths.pas', GR32_VectorUtils in '..\GR32_VectorUtils.pas', GR32_Geometry in '..\GR32_Geometry.pas', GR32_Text_VCL in '..\GR32_Text_VCL.pas', GR32_Brushes in '..\GR32_Brushes.pas'; end. |
Added src/graphics32/Packages/GR32_D7.res.
cannot compute difference between binary files
Added src/graphics32/Packages/GR32_DSGN_CB6.bpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | <?xml version='1.0' encoding='utf-8' ?> <!-- C++Builder XML Project --> <PROJECT> <MACROS> <VERSION value="BCB.06.00"/> <PROJECT value="GR32_DSGN_CB6.bpl"/> <OBJFILES value="GR32_DSGN_CB6.obj ..\GR32_Reg.obj ..\GR32_Dsgn_Bitmap.obj ..\GR32_Dsgn_Color.obj"/> <RESFILES value="..\GR32_Reg.dcr"/> <IDLFILES value=""/> <IDLGENFILES value=""/> <DEFFILE value=""/> <RESDEPEN value="$(RESFILES) ..\GR32_Dsgn_Bitmap.dfm"/> <LIBFILES value=""/> <LIBRARIES value=""/> <SPARELIBS value="rtl.lib vcl.lib dclstd.lib"/> <PACKAGES value="designide.bpi rtl.bpi vcl.bpi GR32_CB6.bpi dclstd.bpi"/> <PATHCPP value=".;"/> <PATHPAS value=".;..;..;.."/> <PATHRC value=".;"/> <PATHASM value=".;"/> <DEBUGLIBPATH value="$(BCB)\lib\debug"/> <RELEASELIBPATH value="$(BCB)\lib\release"/> <LINKER value="ilink32"/> <USERDEFINES value="_DEBUG"/> <SYSDEFINES value="_RTLDLL;NO_STRICT;USEPACKAGES"/> <MAINSOURCE value="GR32_DSGN_CB6.cpp"/> <INCLUDEPATH value="..\;$(BCB)\include;$(BCB)\include\vcl"/> <LIBPATH value="..\;$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib"/> <WARNINGS value="-w-par -w-8027 -w-8026"/> <OTHERFILES value=""/> </MACROS> <OPTIONS> <CFLAG1 value="-Od -H=$(BCB)\lib\vcl60.csm -Hc -Vx -Ve -X- -r- -a8 -b- -k -y -v -vi- -c -tWM"/> <PFLAGS value="-$YD -$W -$O- -$A8 -v -JPHNE -M -LUdclstd -LUdesignide"/> <RFLAGS value=""/> <AFLAGS value="/mx /w2 /zd"/> <LFLAGS value="-D"" -aa -Tpp -x -Gn -Gl -Gi -v"/> <OTHERFILES value=""/> </OPTIONS> <LINKER> <ALLOBJ value="c0pkg32.obj $(PACKAGES) Memmgr.Lib sysinit.obj $(OBJFILES)"/> <ALLRES value="$(RESFILES)"/> <ALLLIB value="$(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib"/> <OTHERFILES value=""/> </LINKER> <FILELIST> <FILE FILENAME="GR32_DSGN_CB6.cpp" FORMNAME="" UNITNAME="GR32_DSGN_CB6" CONTAINERID="CCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Reg.pas" FORMNAME="" UNITNAME="GR32_Reg" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Reg.dcr" FORMNAME="" UNITNAME="" CONTAINERID="DcrTool" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Dsgn_Bitmap.pas" FORMNAME="PictureEditorForm" UNITNAME="GR32_Dsgn_Bitmap" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="..\GR32_Dsgn_Color.pas" FORMNAME="" UNITNAME="GR32_Dsgn_Color" CONTAINERID="PascalCompiler" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="designide.bpi" FORMNAME="" UNITNAME="designide" CONTAINERID="BPITool" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="rtl.bpi" FORMNAME="" UNITNAME="rtl" CONTAINERID="BPITool" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="vcl.bpi" FORMNAME="" UNITNAME="vcl" CONTAINERID="BPITool" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="GR32_CB6.bpi" FORMNAME="" UNITNAME="GR32_CB6" CONTAINERID="BPITool" DESIGNCLASS="" LOCALCOMMAND=""/> <FILE FILENAME="dclstd.bpi" FORMNAME="" UNITNAME="dclstd" CONTAINERID="BPITool" DESIGNCLASS="" LOCALCOMMAND=""/> </FILELIST> <BUILDTOOLS> </BUILDTOOLS> <IDEOPTIONS> </IDEOPTIONS> </PROJECT> |
Added src/graphics32/Packages/GR32_DSGN_CB6.cpp.
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | //--------------------------------------------------------------------------- #include <basepch.h> #pragma hdrstop USEFORMNS("..\GR32_Dsgn_Bitmap.pas", Gr32_dsgn_bitmap, PictureEditorForm); //--------------------------------------------------------------------------- #pragma package(smart_init) //--------------------------------------------------------------------------- // Package source. //--------------------------------------------------------------------------- #pragma argsused int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) { return 1; } //--------------------------------------------------------------------------- |
Added src/graphics32/Packages/GR32_DSGN_CB6.res.
cannot compute difference between binary files
Added src/graphics32/Packages/GR32_DSGN_D2005.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | package GR32_DSGN_D2005; {$R *.res} {$R '..\GR32_Reg.dcr'} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32 Design Time Package'} {$IMPLICITBUILD ON} requires designide, vcl, rtl, GR32_D2005; contains GR32_Dsgn_Bitmap in '..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\GR32_Reg.pas', GR32_Dsgn_Color in '..\GR32_Dsgn_Color.pas', GR32_Dsgn_Misc in '..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/GR32_DSGN_D5.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | package GR32_DSGN_D5; {$R *.RES} {$R '..\GR32_Reg.dcr'} {$ALIGN ON} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32 Design Time Package'} {$DESIGNONLY} {$IMPLICITBUILD ON} requires vcl50, dclstd50, GR32_D5; contains GR32_Dsgn_Bitmap in '..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\GR32_Reg.pas', GR32_Dsgn_Color in '..\GR32_Dsgn_Color.pas', GR32_Dsgn_Misc in '..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/GR32_DSGN_D5.res.
cannot compute difference between binary files
Added src/graphics32/Packages/GR32_DSGN_D6.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | package GR32_DSGN_D6; {$R *.res} {$R '..\GR32_Reg.dcr'} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32 Design Time Package'} {$IMPLICITBUILD ON} requires designide, vcl, GR32_D6, rtl; contains GR32_Dsgn_Bitmap in '..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\GR32_Reg.pas', GR32_Dsgn_Color in '..\GR32_Dsgn_Color.pas', GR32_Dsgn_Misc in '..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/GR32_DSGN_D6.res.
cannot compute difference between binary files
Added src/graphics32/Packages/GR32_DSGN_D7.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | package GR32_DSGN_D7; {$R *.res} {$R '..\GR32_Reg.dcr'} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32 Design Time Package'} {$IMPLICITBUILD ON} requires designide, vcl, rtl, GR32_D7; contains GR32_Dsgn_Bitmap in '..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\GR32_Reg.pas', GR32_Dsgn_Color in '..\GR32_Dsgn_Color.pas', GR32_Dsgn_Misc in '..\GR32_Dsgn_Misc.pas', GR32_ColorGradients in '..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\GR32_ColorSwatch.pas'; end. |
Added src/graphics32/Packages/GR32_DSGN_D7.res.
cannot compute difference between binary files
Added src/graphics32/Packages/GR32_DSGN_Lazarus.lpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | <?xml version="1.0"?> <CONFIG> <Package Version="4"> <Name Value="GR32_DSGN_Lazarus"/> <Author Value="Team Graphics32"/> <CompilerOptions> <Version Value="11"/> <SearchPaths> <IncludeFiles Value=".."/> <OtherUnitFiles Value="..;../Packages"/> <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)/$(LCLWidgetType)"/> </SearchPaths> <Parsing> <SyntaxOptions> <SyntaxMode Value="Delphi"/> <CStyleOperator Value="False"/> <UseAnsiStrings Value="False"/> </SyntaxOptions> </Parsing> <Other> <CompilerMessages> <UseMsgFile Value="True"/> </CompilerMessages> <CompilerPath Value="$(CompPath)"/> </Other> </CompilerOptions> <Description Value="Graphics32 is a library designed for fast 32-bit graphics handling on Delphi and Kylix. Optimized for 32-bit pixel formats, it provides fast operations with pixels and graphic primitives, and in most cases Graphics32 outperforms the standard TCanvas classes. It is almost a hundred times faster in per-pixel access and about 2–5 times faster in drawing lines. Features Some of Graphics32 features include: * Fast per-pixel access up to 100 times faster compared to standard TBitmap; * High-performance Bitmap alpha blending (including per-pixel alpha blending); * Pixel, line and polygon antialiasing with sub-pixel accuracy (combined with alpha blending); * Arbitrary polygon transformations and custom fillings; * Bitmap resampling with high quality reconstruction filters (e.g. Lanczos, Cubic, Mitchell); * A unique state-of-the-art rasterization system; * Affine transformations of bitmaps: rotations, scaling, etc with sub-pixel accuracy; * Arbitrary projective transformations of bitmaps; * Arbitrary remapping transformations of bitmaps (e.g. for Warping, Morphing); * Flexible supersampling implementation for maximum sampling quality; * Flicker-free image displaying components with optimized double buffering via advanced MicroTiles? based repaint optimizer; * Multiple customizible easy-to-use overlay layers; * Locking of bitmaps for safe multithreading; * A property editor for RGB and alpha channel loading; * Design-time loading of image formats supported by standard TPicture; * Works on Borland Delphi, C++ Builder and Kylix (The last version that supported Kylix was 1.8.3). As of version 1.5.1b Graphics32 is licensed under the terms of the Mozilla Public License."/> <License Value="GNU Library or Lesser General Public License (LGPL) Mozilla Public License 1.1 (MPL 1.1)"/> <Version Major="2"/> <Files Count="5"> <Item1> <Filename Value="../GR32_Reg.pas"/> <HasRegisterProc Value="True"/> <UnitName Value="GR32_Reg"/> </Item1> <Item2> <Filename Value="../GR32_Dsgn_Misc.pas"/> <UnitName Value="GR32_Dsgn_Misc"/> </Item2> <Item3> <Filename Value="../GR32_Dsgn_Color.pas"/> <UnitName Value="GR32_Dsgn_Color"/> </Item3> <Item4> <Filename Value="../GR32_Dsgn_Bitmap.lfm"/> <Type Value="LFM"/> </Item4> <Item5> <Filename Value="../GR32_Dsgn_Bitmap.pas"/> <UnitName Value="GR32_Dsgn_Bitmap"/> </Item5> </Files> <Type Value="DesignTime"/> <RequiredPkgs Count="3"> <Item1> <PackageName Value="GR32_Lazarus"/> </Item1> <Item2> <PackageName Value="LCL"/> <MinVersion Major="1" Valid="True"/> </Item2> <Item3> <PackageName Value="IDEIntf"/> </Item3> </RequiredPkgs> <UsageOptions> <UnitPath Value="$(PkgOutDir)"/> </UsageOptions> <PublishOptions> <Version Value="2"/> <IgnoreBinaries Value="False"/> </PublishOptions> <CustomOptions Items="ExternHelp" Version="2"> <_ExternHelp Items="Count"/> </CustomOptions> </Package> </CONFIG> |
Added src/graphics32/Packages/GR32_DSGN_Lazarus.pas.
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | { This file was automatically created by Lazarus. Do not edit! This source is only used to compile and install the package. } unit GR32_DSGN_Lazarus; interface uses GR32_Reg, GR32_Dsgn_Misc, GR32_Dsgn_Color, GR32_Dsgn_Bitmap, LazarusPackageIntf; implementation procedure Register; begin RegisterUnit('GR32_Reg', @GR32_Reg.Register); end; initialization RegisterPackage('GR32_DSGN_Lazarus', @Register); end. |
Added src/graphics32/Packages/GR32_DSGN_RS2006.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | package GR32_DSGN_RS2006; {$R *.res} {$R '..\GR32_Reg.dcr'} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32 Design Time Package'} {$IMPLICITBUILD ON} requires designide, vcl, rtl, GR32_RS2006; contains GR32_Dsgn_Bitmap in '..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\GR32_Reg.pas', GR32_Dsgn_Color in '..\GR32_Dsgn_Color.pas', GR32_Dsgn_Misc in '..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/GR32_DSGN_RS2007.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | package GR32_DSGN_RS2007; {$R *.res} {$R '..\GR32_Reg.dcr'} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32 Design Time Package'} {$DESIGNONLY} {$IMPLICITBUILD ON} requires designide, vcl, rtl, GR32_RS2007; contains GR32_Dsgn_Bitmap in '..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\GR32_Reg.pas', GR32_Dsgn_Color in '..\GR32_Dsgn_Color.pas', GR32_Dsgn_Misc in '..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/GR32_DSGN_RS2009.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | package GR32_DSGN_RS2009; {$R *.res} {$R '..\GR32_Reg.dcr'} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32 Design Time Package'} {$IMPLICITBUILD ON} requires designide, vcl, rtl, GR32_RS2009; contains GR32_Dsgn_Bitmap in '..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\GR32_Reg.pas', GR32_Dsgn_Color in '..\GR32_Dsgn_Color.pas', GR32_Dsgn_Misc in '..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/GR32_Lazarus.lpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 | <?xml version="1.0"?> <CONFIG> <Package Version="4"> <PathDelim Value="\"/> <Name Value="GR32_Lazarus"/> <Author Value="Team Graphics32"/> <CompilerOptions> <Version Value="11"/> <PathDelim Value="\"/> <SearchPaths> <IncludeFiles Value=".."/> <OtherUnitFiles Value=".."/> <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\$(LCLWidgetType)"/> </SearchPaths> <Parsing> <SyntaxOptions> <SyntaxMode Value="Delphi"/> <CStyleOperator Value="False"/> <UseAnsiStrings Value="False"/> </SyntaxOptions> </Parsing> <Other> <CompilerMessages> <UseMsgFile Value="True"/> </CompilerMessages> <CompilerPath Value="$(CompPath)"/> </Other> </CompilerOptions> <Description Value="Graphics32 is a library designed for fast 32-bit graphics handling on Delphi and Kylix. Optimized for 32-bit pixel formats, it provides fast operations with pixels and graphic primitives, and in most cases Graphics32 outperforms the standard TCanvas classes. It is almost a hundred times faster in per-pixel access and about 2–5 times faster in drawing lines. Features Some of Graphics32 features include: * Fast per-pixel access up to 100 times faster compared to standard TBitmap; * High-performance Bitmap alpha blending (including per-pixel alpha blending); * Pixel, line and polygon antialiasing with sub-pixel accuracy (combined with alpha blending); * Arbitrary polygon transformations and custom fillings; * Bitmap resampling with high quality reconstruction filters (e.g. Lanczos, Cubic, Mitchell); * A unique state-of-the-art rasterization system; * Affine transformations of bitmaps: rotations, scaling, etc with sub-pixel accuracy; * Arbitrary projective transformations of bitmaps; * Arbitrary remapping transformations of bitmaps (e.g. for Warping, Morphing); * Flexible supersampling implementation for maximum sampling quality; * Flicker-free image displaying components with optimized double buffering via advanced MicroTiles? based repaint optimizer; * Multiple customizible easy-to-use overlay layers; * Locking of bitmaps for safe multithreading; * A property editor for RGB and alpha channel loading; * Design-time loading of image formats supported by standard TPicture; * Works on Borland Delphi, C++ Builder and Kylix (The last version that supported Kylix was 1.8.3). As of version 1.5.1b Graphics32 is licensed under the terms of the Mozilla Public License."/> <License Value="GNU Library or Lesser General Public License (LGPL) Mozilla Public License 1.1 (MPL 1.1)"/> <Version Major="2"/> <Files Count="19"> <Item1> <Filename Value="..\GR32.pas"/> <UnitName Value="GR32"/> </Item1> <Item2> <Filename Value="..\GR32_Blend.pas"/> <UnitName Value="GR32_Blend"/> </Item2> <Item3> <Filename Value="..\GR32_Containers.pas"/> <UnitName Value="GR32_Containers"/> </Item3> <Item4> <Filename Value="..\GR32_ExtImage.pas"/> <UnitName Value="GR32_ExtImage"/> </Item4> <Item5> <Filename Value="..\GR32_Filters.pas"/> <UnitName Value="GR32_Filters"/> </Item5> <Item6> <Filename Value="..\GR32_Image.pas"/> <UnitName Value="GR32_Image"/> </Item6> <Item7> <Filename Value="..\GR32_Layers.pas"/> <UnitName Value="GR32_Layers"/> </Item7> <Item8> <Filename Value="..\GR32_LowLevel.pas"/> <UnitName Value="GR32_LowLevel"/> </Item8> <Item9> <Filename Value="..\GR32_Math.pas"/> <UnitName Value="GR32_Math"/> </Item9> <Item10> <Filename Value="..\GR32_MicroTiles.pas"/> <UnitName Value="GR32_MicroTiles"/> </Item10> <Item11> <Filename Value="..\GR32_OrdinalMaps.pas"/> <UnitName Value="GR32_OrdinalMaps"/> </Item11> <Item12> <Filename Value="..\GR32_Polygons.pas"/> <UnitName Value="GR32_Polygons"/> </Item12> <Item13> <Filename Value="..\GR32_RangeBars.pas"/> <UnitName Value="GR32_RangeBars"/> </Item13> <Item14> <Filename Value="..\GR32_Rasterizers.pas"/> <UnitName Value="GR32_Rasterizers"/> </Item14> <Item15> <Filename Value="..\GR32_RepaintOpt.pas"/> <UnitName Value="GR32_RepaintOpt"/> </Item15> <Item16> <Filename Value="..\GR32_Resamplers.pas"/> <UnitName Value="GR32_Resamplers"/> </Item16> <Item17> <Filename Value="..\GR32_System.pas"/> <UnitName Value="GR32_System"/> </Item17> <Item18> <Filename Value="..\GR32_Transforms.pas"/> <UnitName Value="GR32_Transforms"/> </Item18> <Item19> <Filename Value="..\GR32_VectorMaps.pas"/> <UnitName Value="GR32_VectorMaps"/> </Item19> </Files> <RequiredPkgs Count="3"> <Item1> <PackageName Value="IDEIntf"/> </Item1> <Item2> <PackageName Value="FCL"/> <MinVersion Major="1" Valid="True"/> </Item2> <Item3> <PackageName Value="LCL"/> <MinVersion Major="1" Valid="True"/> </Item3> </RequiredPkgs> <UsageOptions> <UnitPath Value="$(PkgOutDir)"/> </UsageOptions> <PublishOptions> <Version Value="2"/> <DestinationDirectory Value="$(TestDir)\publishedpackage\"/> <IgnoreBinaries Value="False"/> </PublishOptions> <CustomOptions Items="ExternHelp" Version="2"> <_ExternHelp Items="Count"/> </CustomOptions> </Package> </CONFIG> |
Added src/graphics32/Packages/GR32_Lazarus.pas.
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | { This file was automatically created by Lazarus. Do not edit! This source is only used to compile and install the package. } unit GR32_Lazarus; interface uses GR32, GR32_Blend, GR32_Containers, GR32_ExtImage, GR32_Filters, GR32_Image, GR32_Layers, GR32_LowLevel, GR32_Math, GR32_MicroTiles, GR32_OrdinalMaps, GR32_Polygons, GR32_RangeBars, GR32_Rasterizers, GR32_RepaintOpt, GR32_Resamplers, GR32_System, GR32_Transforms, GR32_VectorMaps; implementation end. |
Added src/graphics32/Packages/GR32_RS2006.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | package GR32_RS2006; {$R *.res} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32'} {$IMPLICITBUILD ON} requires vcl, rtl; contains GR32 in '..\GR32.pas', GR32_Backends in '..\GR32_Backends.pas', GR32_Backends_Generic in '..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\GR32_Backends_VCL.pas', GR32_Bindings in '..\GR32_Bindings.pas', GR32_Blend in '..\GR32_Blend.pas', GR32_Brushes in '..\GR32_Brushes.pas', GR32_ColorGradients in '..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\GR32_ColorPicker.pas', GR32_Containers in '..\GR32_Containers.pas', GR32_ExtImage in '..\GR32_ExtImage.pas', GR32_Filters in '..\GR32_Filters.pas', GR32_Geometry in '..\GR32_Geometry.pas', GR32_Image in '..\GR32_Image.pas', GR32_Layers in '..\GR32_Layers.pas', GR32_LowLevel in '..\GR32_LowLevel.pas', GR32_Math in '..\GR32_Math.pas', GR32_MicroTiles in '..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\GR32_OrdinalMaps.pas', GR32_Paths in '..\GR32_Paths.pas', GR32_Polygons in '..\GR32_Polygons.pas', GR32_RangeBars in '..\GR32_RangeBars.pas', GR32_Rasterizers in '..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\GR32_Resamplers.pas', GR32_System in '..\GR32_System.pas', GR32_Transforms in '..\GR32_Transforms.pas', GR32_VectorMaps in '..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\GR32_VectorUtils.pas', GR32_VPR in '..\GR32_VPR.pas', GR32_Text_VCL in '..\GR32_Text_VCL.pas', GR32_XPThemes in '..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/GR32_RS2007.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | package GR32_RS2007; {$R *.res} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\GR32.pas', GR32_Backends in '..\GR32_Backends.pas', GR32_Backends_Generic in '..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\GR32_Backends_VCL.pas', GR32_Bindings in '..\GR32_Bindings.pas', GR32_Blend in '..\GR32_Blend.pas', GR32_Brushes in '..\GR32_Brushes.pas', GR32_ColorGradients in '..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\GR32_ColorPicker.pas', GR32_Containers in '..\GR32_Containers.pas', GR32_ExtImage in '..\GR32_ExtImage.pas', GR32_Filters in '..\GR32_Filters.pas', GR32_Geometry in '..\GR32_Geometry.pas', GR32_Image in '..\GR32_Image.pas', GR32_Layers in '..\GR32_Layers.pas', GR32_LowLevel in '..\GR32_LowLevel.pas', GR32_Math in '..\GR32_Math.pas', GR32_MicroTiles in '..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\GR32_OrdinalMaps.pas', GR32_Paths in '..\GR32_Paths.pas', GR32_Polygons in '..\GR32_Polygons.pas', GR32_RangeBars in '..\GR32_RangeBars.pas', GR32_Rasterizers in '..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\GR32_Resamplers.pas', GR32_System in '..\GR32_System.pas', GR32_Text_VCL in '..\GR32_Text_VCL.pas', GR32_Transforms in '..\GR32_Transforms.pas', GR32_VectorMaps in '..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\GR32_VectorUtils.pas', GR32_VPR in '..\GR32_VPR.pas', GR32_XPThemes in '..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/GR32_RS2009.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | package GR32_RS2009; {$R *.res} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DESCRIPTION 'Graphics32'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\GR32.pas', GR32_Backends in '..\GR32_Backends.pas', GR32_Backends_Generic in '..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\GR32_Backends_VCL.pas', GR32_Bindings in '..\GR32_Bindings.pas', GR32_Blend in '..\GR32_Blend.pas', GR32_Brushes in '..\GR32_Brushes.pas', GR32_ColorGradients in '..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\GR32_ColorPicker.pas', GR32_Containers in '..\GR32_Containers.pas', GR32_ExtImage in '..\GR32_ExtImage.pas', GR32_Filters in '..\GR32_Filters.pas', GR32_Geometry in '..\GR32_Geometry.pas', GR32_Image in '..\GR32_Image.pas', GR32_Layers in '..\GR32_Layers.pas', GR32_LowLevel in '..\GR32_LowLevel.pas', GR32_Math in '..\GR32_Math.pas', GR32_MicroTiles in '..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\GR32_OrdinalMaps.pas', GR32_Paths in '..\GR32_Paths.pas', GR32_Polygons in '..\GR32_Polygons.pas', GR32_RangeBars in '..\GR32_RangeBars.pas', GR32_Rasterizers in '..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\GR32_Resamplers.pas', GR32_System in '..\GR32_System.pas', GR32_Transforms in '..\GR32_Transforms.pas', GR32_VectorMaps in '..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\GR32_VectorUtils.pas', GR32_VPR in '..\GR32_VPR.pas', GR32_Text_VCL in '..\GR32_Text_VCL.pas', GR32_XPThemes in '..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/Gen.bat.
> > | 1 2 | @rem See PackagesGenerator.ini for comments PackagesGenerator -config PackagesGenerator.ini -hide -skip |
Added src/graphics32/Packages/PackagesGenerator.ini.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | ; Config for https://github.com/errorcalc/PackagesGenerator ; to autogenerate .{dpk,dproj,groupproj} for all Delphi versions ; from 2010 till RX2, based on the XE3 files (as currently ; configured below). [Folders] Base=XE3\ ;Gen= GroupAbove=False [Versions] RX2=RX2 RX1=RX1 RX=RX XE8=XE8 XE7=XE7 XE6=XE6 XE5=XE5 XE4=XE4 ;XE3=XE3 XE2=XE2 XE=XE 2010=2010 [Files] GR32_D.dpk GR32_R.dpk GR32_D.dproj GR32_R.dproj GR32.groupproj |
Added src/graphics32/Packages/RX/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/RX/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'RX'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/RX/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>RX</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/RX/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | package GR32_R; {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'RX'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/RX/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>RX</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/RX1/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/RX1/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'RX1'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/RX1/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>RX1</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/RX1/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | package GR32_R; {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'RX1'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/RX1/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>RX1</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/RX2/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/RX2/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'RX2'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/RX2/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>RX2</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/RX2/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | package GR32_R; {$R *.res} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'RX2'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/RX2/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>RX2</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/XE/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'XE'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/XE/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | package GR32_R; {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'XE'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/XE/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE2/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/XE2/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'XE2'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/XE2/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE2</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE2/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | package GR32_R; {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'XE2'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/XE2/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE2</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE3/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/XE3/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'XE3'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/XE3/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE3</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\..\GR32_Reg.pas"/> <DCCReference Include="..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE3/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | package GR32_R; {$R *.res} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'XE3'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/XE3/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''"> <Cfg_1_Win32>true</Cfg_1_Win32> <CfgParent>Cfg_1</CfgParent> <Cfg_1>true</Cfg_1> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE3</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <DCC_CBuilderOutput>All</DCC_CBuilderOutput> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\..\GR32.pas"/> <DCCReference Include="..\..\GR32_Backends.pas"/> <DCCReference Include="..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\..\GR32_Bindings.pas"/> <DCCReference Include="..\..\GR32_Blend.pas"/> <DCCReference Include="..\..\GR32_Brushes.pas"/> <DCCReference Include="..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\..\GR32_Containers.pas"/> <DCCReference Include="..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\..\GR32_Filters.pas"/> <DCCReference Include="..\..\GR32_Geometry.pas"/> <DCCReference Include="..\..\GR32_Image.pas"/> <DCCReference Include="..\..\GR32_Layers.pas"/> <DCCReference Include="..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\..\GR32_Math.pas"/> <DCCReference Include="..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\..\GR32_Paths.pas"/> <DCCReference Include="..\..\GR32_Polygons.pas"/> <DCCReference Include="..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\..\GR32_System.pas"/> <DCCReference Include="..\..\GR32_Transforms.pas"/> <DCCReference Include="..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\..\GR32_VPR.pas"/> <DCCReference Include="..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE4/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/XE4/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'XE4'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/XE4/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE4</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE4/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | package GR32_R; {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'XE4'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/XE4/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE4</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE5/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/XE5/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'XE5'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/XE5/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE5</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE5/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | package GR32_R; {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'XE5'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/XE5/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE5</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE6/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/XE6/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'XE6'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/XE6/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE6</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE6/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | package GR32_R; {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'XE6'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/XE6/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE6</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE7/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/XE7/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'XE7'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/XE7/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE7</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE7/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | package GR32_R; {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'XE7'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/XE7/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE7</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE8/GR32.groupproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{FFF0FA35-7520-45EB-AB10-70273976B07D}</ProjectGuid> </PropertyGroup> <ItemGroup> <Projects Include="GR32_R.dproj"> <Dependencies/> </Projects> <Projects Include="GR32_D.dproj"> <Dependencies/> </Projects> </ItemGroup> <ProjectExtensions> <Borland.Personality>Default.Personality.12</Borland.Personality> <Borland.ProjectType/> <BorlandProject> <Default.Personality/> </BorlandProject> </ProjectExtensions> <Target Name="GR32_R"> <MSBuild Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Clean"> <MSBuild Targets="Clean" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_R:Make"> <MSBuild Targets="Make" Projects="GR32_R.dproj"/> </Target> <Target Name="GR32_D"> <MSBuild Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Clean"> <MSBuild Targets="Clean" Projects="GR32_D.dproj"/> </Target> <Target Name="GR32_D:Make"> <MSBuild Targets="Make" Projects="GR32_D.dproj"/> </Target> <Target Name="Build"> <CallTarget Targets="GR32_R;GR32_D"/> </Target> <Target Name="Clean"> <CallTarget Targets="GR32_R:Clean;GR32_D:Clean"/> </Target> <Target Name="Make"> <CallTarget Targets="GR32_R:Make;GR32_D:Make"/> </Target> <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> </Project> |
Added src/graphics32/Packages/XE8/GR32_D.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | package GR32_D; {$R '..\..\GR32_Reg.dcr'} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST OFF} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32 Design Time Package'} {$LIBSUFFIX 'XE8'} {$IMPLICITBUILD ON} requires DesignIde, Rtl, Vcl, VclSmp, GR32_R; contains GR32_Dsgn_Bitmap in '..\..\GR32_Dsgn_Bitmap.pas' {PictureEditorForm}, GR32_Reg in '..\..\GR32_Reg.pas', GR32_Dsgn_Color in '..\..\GR32_Dsgn_Color.pas', GR32_Dsgn_ColorPicker in '..\..\GR32_Dsgn_ColorPicker.pas', GR32_Dsgn_Misc in '..\..\GR32_Dsgn_Misc.pas'; end. |
Added src/graphics32/Packages/XE8/GR32_D.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{4EC12971-C175-488B-A004-DEECBF8CE56F}</ProjectGuid> <MainSource>GR32_D.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>1</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <DCC_N>false</DCC_N> <DCC_F>false</DCC_F> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE8</DllSuffix> <GenPackage>true</GenPackage> <DCC_Description>Graphics32 Design Time Package</DCC_Description> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_UsePackage>vcl;rtl;GR32_R;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_UsePackage>vcl;rtl;VclSmp;$(DCC_UsePackage)</DCC_UsePackage> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="..\..\GR32_Reg.dcr"/> <DCCReference Include="DesignIde.dcp"/> <DCCReference Include="Rtl.dcp"/> <DCCReference Include="Vcl.dcp"/> <DCCReference Include="VclSmp.dcp"/> <DCCReference Include="GR32_R.dcp"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Bitmap.pas"> <Form>PictureEditorForm</Form> </DCCReference> <DCCReference Include="..\XE3\..\..\GR32_Reg.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Color.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Dsgn_Misc.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_D.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">False</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">False</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Packages/XE8/GR32_R.dpk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | package GR32_R; {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} {$EXTENDEDSYNTAX ON} {$IMPORTEDDATA ON} {$IOCHECKS ON} {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} {$OPTIMIZATION OFF} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES ON} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} {$WRITEABLECONST ON} {$MINENUMSIZE 1} {$IMAGEBASE $400000} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Graphics32'} {$LIBSUFFIX 'XE8'} {$RUNONLY} {$IMPLICITBUILD ON} requires vcl; contains GR32 in '..\..\GR32.pas', GR32_Backends in '..\..\GR32_Backends.pas', GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', GR32_Bindings in '..\..\GR32_Bindings.pas', GR32_Blend in '..\..\GR32_Blend.pas', GR32_Brushes in '..\..\GR32_Brushes.pas', GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', GR32_Containers in '..\..\GR32_Containers.pas', GR32_ExtImage in '..\..\GR32_ExtImage.pas', GR32_Filters in '..\..\GR32_Filters.pas', GR32_Geometry in '..\..\GR32_Geometry.pas', GR32_Image in '..\..\GR32_Image.pas', GR32_Layers in '..\..\GR32_Layers.pas', GR32_LowLevel in '..\..\GR32_LowLevel.pas', GR32_Math in '..\..\GR32_Math.pas', GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', GR32_Paths in '..\..\GR32_Paths.pas', GR32_Polygons in '..\..\GR32_Polygons.pas', GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', GR32_RangeBars in '..\..\GR32_RangeBars.pas', GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', GR32_Resamplers in '..\..\GR32_Resamplers.pas', GR32_System in '..\..\GR32_System.pas', GR32_Transforms in '..\..\GR32_Transforms.pas', GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', GR32_VPR in '..\..\GR32_VPR.pas', GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', GR32_XPThemes in '..\..\GR32_XPThemes.pas'; end. |
Added src/graphics32/Packages/XE8/GR32_R.dproj.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> <ProjectGuid>{AA13AB30-823B-4E0A-809C-30E0A0B4FF2B}</ProjectGuid> <MainSource>GR32_R.dpk</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Release</Config> <TargetedPlatforms>3</TargetedPlatforms> <AppType>Package</AppType> <FrameworkType>VCL</FrameworkType> <ProjectVersion>14.4</ProjectVersion> <Platform Condition="'$(Platform)'==''">Win32</Platform> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> <Base_Win64>true</Base_Win64> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> <Cfg_1>true</Cfg_1> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <Cfg_2>true</Cfg_2> <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> <Cfg_2_Win64>true</Cfg_2_Win64> <CfgParent>Cfg_2</CfgParent> <Cfg_2>true</Cfg_2> <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_K>false</DCC_K> <DCC_S>false</DCC_S> <GenDll>true</GenDll> <DCC_N>false</DCC_N> <DCC_E>false</DCC_E> <VerInfo_Locale>1031</VerInfo_Locale> <RuntimeOnlyPackage>true</RuntimeOnlyPackage> <DCC_ImageBase>00400000</DCC_ImageBase> <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> <DllSuffix>XE8</DllSuffix> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;CFBundleExecutable=</VerInfo_Keys> <DCC_F>false</DCC_F> <GenPackage>true</GenPackage> <DCC_Description>Graphics32</DCC_Description> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_DebugInformation>false</DCC_DebugInformation> <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> <DCC_Optimize>false</DCC_Optimize> <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_Locale>1033</VerInfo_Locale> <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> <DCCReference Include="vcl.dcp"/> <DCCReference Include="..\XE3\..\..\GR32.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_Generic.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Backends_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Bindings.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Blend.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Brushes.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorGradients.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorPicker.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ColorSwatch.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Containers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_ExtImage.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Filters.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Geometry.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Image.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Layers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_LowLevel.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Math.pas"/> <DCCReference Include="..\XE3\..\..\GR32_MicroTiles.pas"/> <DCCReference Include="..\XE3\..\..\GR32_OrdinalMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Paths.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Polygons.pas"/> <DCCReference Include="..\XE3\..\..\GR32_PolygonsAggLite.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RangeBars.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Rasterizers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_RepaintOpt.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Resamplers.pas"/> <DCCReference Include="..\XE3\..\..\GR32_System.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Transforms.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorMaps.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VectorUtils.pas"/> <DCCReference Include="..\XE3\..\..\GR32_VPR.pas"/> <DCCReference Include="..\XE3\..\..\GR32_Text_VCL.pas"/> <DCCReference Include="..\XE3\..\..\GR32_XPThemes.pas"/> <BuildConfiguration Include="Debug"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> <BuildConfiguration Include="Base"> <Key>Base</Key> </BuildConfiguration> <BuildConfiguration Include="Release"> <Key>Cfg_1</Key> <CfgParent>Base</CfgParent> </BuildConfiguration> </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> <Borland.ProjectType>Package</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> <Source Name="MainSource">GR32_R.dpk</Source> </Source> <VersionInfo> <VersionInfo Name="IncludeVerInfo">True</VersionInfo> <VersionInfo Name="AutoIncBuild">False</VersionInfo> <VersionInfo Name="MajorVer">1</VersionInfo> <VersionInfo Name="MinorVer">0</VersionInfo> <VersionInfo Name="Release">0</VersionInfo> <VersionInfo Name="Build">0</VersionInfo> <VersionInfo Name="Debug">False</VersionInfo> <VersionInfo Name="PreRelease">False</VersionInfo> <VersionInfo Name="Special">False</VersionInfo> <VersionInfo Name="Private">False</VersionInfo> <VersionInfo Name="DLL">False</VersionInfo> <VersionInfo Name="Locale">1031</VersionInfo> <VersionInfo Name="CodePage">1252</VersionInfo> </VersionInfo> <VersionInfoKeys> <VersionInfoKeys Name="CompanyName"/> <VersionInfoKeys Name="FileDescription"/> <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="InternalName"/> <VersionInfoKeys Name="LegalCopyright"/> <VersionInfoKeys Name="LegalTrademarks"/> <VersionInfoKeys Name="OriginalFilename"/> <VersionInfoKeys Name="ProductName"/> <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> <VersionInfoKeys Name="Comments"/> <VersionInfoKeys Name="CFBundleName"/> <VersionInfoKeys Name="CFBundleDisplayName"/> <VersionInfoKeys Name="CFBundleIdentifier"/> <VersionInfoKeys Name="CFBundleVersion"/> <VersionInfoKeys Name="CFBundlePackageType"/> <VersionInfoKeys Name="CFBundleSignature"/> <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> <VersionInfoKeys Name="CFBundleExecutable"/> </VersionInfoKeys> <Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder-Package für Office 2000-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder-Package für Office XP-Server</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver</Excluded_Packages> <Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server</Excluded_Packages> </Excluded_Packages> </Delphi.Personality> <Platforms> <Platform value="Win32">True</Platform> <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> </ProjectExtensions> <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> </Project> |
Added src/graphics32/Readme.txt.
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | See Graphics32.chm file for installation instructions, list of changes, license, and reference. SUPPORT ------- For latest news and support visit the Graphics32 home page at http://graphics32.org and the newsgroup at news://news.graphics32.org . For the lastest version please visit http://sourceforge.net/projects/graphics32 DONATIONS --------- Given that Graphics32 is licensed under the terms of the MPL 1.1 and alternatively the LGPL 2.1 with linking exception, you can use the Graphics32 package free of charge even for commercial and shareware applications. However, if you wish to express your appreciation for the time Alex Denisov spent on developing, documenting and supporting the initial version, he does accept and appreciate donations. If you wish to make your donation, visit the site above. The base amount is US$20, but if you would like to donate more, feel free to order multiple copies of the "Graphics32/G32 donation" product. Thank you for your support. |
Added src/graphics32/_clean.bat.
> > | 1 2 | del /S *.~*;*.bak;*.dcu;*.elf;*.dpu;*.dsk;*.cfg;*.dof;*.kof;*.obj;*.hpp;*.ddp;*.mps;*.mpt;*.map;*.log;*.exe;*.so;*.stat;*.tci;*.o;*.ppu;*.rst del /s /A Thumbs.db |
Added src/tekening.res.
cannot compute difference between binary files