doublecmd-1.1.22/ 0000755 0001750 0000144 00000000000 14743153644 012606 5 ustar alexx users doublecmd-1.1.22/.gitattributes 0000644 0001750 0000144 00000000072 14743153644 015500 0 ustar alexx users *.sh text eol=lf
*.bat -text
language/*.po text eol=lf
doublecmd-1.1.22/.gitignore 0000644 0001750 0000144 00000000700 14743153644 014573 0 ustar alexx users # Lazarus compiler-generated binaries (safe to delete)
*.exe
*.dll
*.so
*.dylib
*.lrs
*.res
*.compiled
*.dbg
*.ppu
*.o
*.or
*.a
*.zdli
*.dsx
*.w?x
units/
/doublecmd
# Lazarus autogenerated files (duplicated info)
*.rst
*.rsj
# Lazarus local files (user-specific info)
*.lps
# Lazarus backups and unit output folders.
# These can be changed by user in Lazarus/project options.
backup/
*.bak
lib/
# Application bundle for Mac OS
*.app/
.DS_Store
doublecmd-1.1.22/LICENSE.md 0000644 0001750 0000144 00000042747 14743153644 014230 0 ustar alexx users ### GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1989, 1991 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.
### Preamble
The licenses for most software are designed to take away your freedom
to share and change it. By contrast, the GNU General Public License is
intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it. (Some other Free Software Foundation software is covered by
the GNU Lesser General Public License instead.) You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, 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 or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if
you distribute copies of the software, or if you modify it.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must show them these terms so they know their
rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on,
we want its recipients to know that what they have is not the
original, so that any problems introduced by others will not reflect
on the original authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary. To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at
all.
The precise terms and conditions for copying, distribution and
modification follow.
### TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
**0.** This License applies to any program or other work which
contains a notice placed by the copyright holder saying it may be
distributed under the terms of this General Public License. The
"Program", below, refers to any such program or work, and a "work
based on the Program" means either the Program or any derivative work
under copyright law: that is to say, a work containing the Program or
a portion of it, either verbatim or with modifications and/or
translated into another language. (Hereinafter, translation is
included without limitation in the term "modification".) Each licensee
is addressed as "you".
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the Program
(independent of having been made by running the Program). Whether that
is true depends on what the Program does.
**1.** You may copy and distribute verbatim copies of the Program's
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 give any other recipients of the Program a copy of this License
along with the Program.
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 Program or any
portion of it, thus forming a work based on the Program, 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)** You must cause the modified files to carry prominent notices
stating that you changed the files and the date of any change.
**b)** You must cause any work that you distribute or publish, that in
whole or in part contains or is derived from the Program or any part
thereof, to be licensed as a whole at no charge to all third parties
under the terms of this License.
**c)** If the modified program normally reads commands interactively
when run, you must cause it, when started running for such interactive
use in the most ordinary way, to print or display an announcement
including an appropriate copyright notice and a notice that there is
no warranty (or else, saying that you provide a warranty) and that
users may redistribute the program under these conditions, and telling
the user how to view a copy of this License. (Exception: if the
Program itself is interactive but does not normally print such an
announcement, your work based on the Program is not required to print
an announcement.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Program,
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 Program, 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 Program.
In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
**3.** You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:
**a)** 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; or,
**b)** Accompany it with a written offer, valid for at least three
years, to give any third party, for a charge no more than your cost of
physically performing source distribution, a complete machine-readable
copy of the corresponding source code, to be distributed under the
terms of Sections 1 and 2 above on a medium customarily used for
software interchange; or,
**c)** Accompany it with the information you received as to the offer
to distribute corresponding source code. (This alternative is allowed
only for noncommercial distribution and only if you received the
program in object code or executable form with such an offer, in
accord with Subsection b above.)
The source code for a work means the preferred form of the work for
making modifications to it. For an executable work, 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 executable. However, as a
special exception, the source code 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.
If distribution of executable or 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 counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.
**4.** You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License. Any attempt otherwise
to copy, modify, sublicense or distribute the Program 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.
**5.** 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 Program or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.
**6.** Each time you redistribute the Program (or any work based on
the Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program 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 to
this License.
**7.** 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 Program at all. For
example, if a patent license would not permit royalty-free
redistribution of the Program 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
Program.
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.
**8.** If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program 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.
**9.** The Free Software Foundation may publish revised and/or new
versions of the 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 Program
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 Program does not specify a
version number of this License, you may choose any version ever
published by the Free Software Foundation.
**10.** If you wish to incorporate parts of the Program into other
free programs whose distribution conditions are different, 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**
**11.** BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE PROGRAM "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
PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
**12.** 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 PROGRAM 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
PROGRAM (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 PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 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 Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these
terms.
To do so, attach the following notices to the program. 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 program's name and an idea of what it does.
Copyright (C) yyyy name of author
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program 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 General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; 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.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) year name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details
type `show w'. This is free software, and you are welcome
to redistribute it under certain conditions; type `show c'
for details.
The hypothetical commands \`show w' and \`show c' should show the
appropriate parts of the General Public License. Of course, the
commands you use may be called something other than \`show w' and
\`show c'; they could even be mouse-clicks or menu items--whatever
suits your program.
You should also get your employer (if you work as a programmer) or
your school, if any, to sign a "copyright disclaimer" for the program,
if necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright
interest in the program `Gnomovision'
(which makes passes at compilers) written
by James Hacker.
signature of Ty Coon, 1 April 1989
Ty Coon, President of Vice
This General Public License does not permit incorporating your program
into proprietary programs. If your program is a subroutine library,
you may consider it more useful to permit linking proprietary
applications with the library. If this is what you want to do, use the
[GNU Lesser General Public
License](https://www.gnu.org/licenses/lgpl.html) instead of this
License.
doublecmd-1.1.22/README.md 0000644 0001750 0000144 00000002633 14743153644 014071 0 ustar alexx users **Double Commander** is a [free](https://www.gnu.org/philosophy/free-sw.html) cross-platform open source file manager with two panels side by side (or one above the other). It is inspired by Total Commander and features some innovative new ideas.
Double Commander can be run on several platforms and operating systems.
It supports 32-bit and 64-bit processors. See [Supported platforms](https://github.com/doublecmd/doublecmd/wiki/Supported-platforms)
for a complete list.
See Double Commander in action in the [Screenshot Gallery](https://doublecmd.sourceforge.io/gallery).
## Where to start
### Download
Go to the [Double Commander download page](https://sourceforge.net/p/doublecmd/wiki/Download) to download the latest release.
You can check the latest version on the [Versions](https://github.com/doublecmd/doublecmd/wiki/Versions) page.
See if Double Commander is supported for your platform on the [Supported
platforms](https://github.com/doublecmd/doublecmd/wiki/Supported-platforms) page.
### Develop
For more information on the development of Double Commander,
see the [Development](https://github.com/doublecmd/doublecmd/wiki/Development) page.
### Discuss
Go to our [forum](https://doublecmd.h1n.ru) for discussions. There are English and Russian sections.
If you want to stay up-to-date with the project, you can check out the available [news feeds](https://github.com/doublecmd/doublecmd/wiki/News-feeds).
doublecmd-1.1.22/build.bat 0000644 0001750 0000144 00000004214 14743153644 014376 0 ustar alexx users @echo off
rem Add Lazarus installation to path
if [%LAZARUS_HOME%] == [] set LAZARUS_HOME=D:\Alexx\Prog\FreePascal\Lazarus
set PATH=%LAZARUS_HOME%;%PATH%
rem You can execute this script with different parameters:
rem components - compiling components needed for doublecmd
rem doublecmd - compiling doublecmd only (release mode)
rem plugins - compiling all doublecmd plugins
rem debug - compiling components, plugins and doublecmd (debug mode)
rem release - compile in release mode (using by default)
if not "%OS_TARGET%" == "" (
set DC_ARCH=%DC_ARCH% --os=%OS_TARGET%
)
if not "%CPU_TARGET%" == "" (
set DC_ARCH=%DC_ARCH% --cpu=%CPU_TARGET%
)
if not "%LCL_PLATFORM%" == "" (
set DC_ARCH=%DC_ARCH% --ws=%LCL_PLATFORM%
)
if "%1"=="components" ( call :components
) else (
if "%1"=="plugins" ( call :plugins
) else (
if "%1"=="beta" ( call :release
) else (
if "%1"=="doublecmd" ( call :doublecmd
) else (
if "%1"=="release" ( call :release
) else (
if "%1"=="darkwin" ( call :darkwin
) else (
if "%1"=="debug" ( call :debug
) else (
if "%1"=="" ( call :release
) else (
echo ERROR: Mode not defined: %1
echo Available modes: components, plugins, doublecmd, release, darkwin, debug
))))))))
GOTO:EOF
:components
call components\build.bat
GOTO:EOF
:plugins
call plugins\build.bat
GOTO:EOF
:release
call :components
call :plugins
call :doublecmd
GOTO:EOF
:debug
call :components
call :plugins
rem Build Double Commander
call :replace_old
lazbuild src\doublecmd.lpi --bm=debug %DC_ARCH%
GOTO:EOF
:doublecmd
rem Build Double Commander
call :replace_old
lazbuild src\doublecmd.lpi --bm=release %DC_ARCH%
call :extract
GOTO:EOF
:darkwin
call :components
call :plugins
rem Build Double Commander
call :replace_old
lazbuild src\doublecmd.lpi --bm=darkwin %DC_ARCH%
call :extract
GOTO:EOF
:extract
rem Build Dwarf LineInfo Extractor
lazbuild tools\extractdwrflnfo.lpi
rem Extract debug line info
tools\extractdwrflnfo doublecmd.dbg
GOTO:EOF
:replace_old
del /Q doublecmd.exe.old
ren doublecmd.exe doublecmd.exe.old
GOTO:EOF
doublecmd-1.1.22/build.sh 0000755 0001750 0000144 00000003170 14743153644 014245 0 ustar alexx users #!/bin/sh
set -e
# You can execute this script with different parameters:
# components - compiling components needed for doublecmd
# doublecmd - compiling doublecmd only (release mode)
# plugins - compiling all doublecmd plugins
# debug - compiling components, plugins and doublecmd (debug mode)
# release - compile in release mode (using by default)
# path to lazbuild
export lazbuild=$(which lazbuild)
# Set up widgetset: gtk2 or qt or qt5 or cocoa
# Set up processor architecture: i386 or x86_64
if [ $2 ]
then export lcl=$2
fi
if [ $lcl ] && [ $CPU_TARGET ]
then export DC_ARCH=$(echo "--widgetset=$lcl")" "$(echo "--cpu=$CPU_TARGET")
elif [ $lcl ]
then export DC_ARCH=$(echo "--widgetset=$lcl")
elif [ $CPU_TARGET ]
then export DC_ARCH=$(echo "--cpu=$CPU_TARGET")
fi
build_doublecmd()
{
# Build Double Commander
$lazbuild src/doublecmd.lpi --bm=release $DC_ARCH
# Build Dwarf LineInfo Extractor
$lazbuild tools/extractdwrflnfo.lpi
# Extract debug line info
chmod a+x tools/extractdwrflnfo
if [ -f doublecmd.dSYM/Contents/Resources/DWARF/doublecmd ]; then
mv -f doublecmd.dSYM/Contents/Resources/DWARF/doublecmd $(pwd)/doublecmd.dbg
fi
tools/extractdwrflnfo doublecmd.dbg
# Strip debug info
strip doublecmd
}
build_release()
{
components/build.sh
plugins/build.sh
build_doublecmd
}
build_debug()
{
components/build.sh
plugins/build.sh
# Build Double Commander
$lazbuild src/doublecmd.lpi --bm=debug $DC_ARCH
}
case $1 in
components) components/build.sh;;
doublecmd) build_doublecmd;;
plugins) plugins/build.sh;;
debug) build_debug;;
*) build_release;;
esac
doublecmd-1.1.22/clean.bat 0000644 0001750 0000144 00000003323 14743153644 014361 0 ustar alexx users @echo Clean up output directory
@del /Q /S units\i386-win32-win32\*.*
@del /Q /S units\x86_64-win64-win32\*.*
@del /Q src\*.*~
@del /Q src\*.~*
@del /Q doublecmd.dbg
@del /Q doublecmd.zdli
@del /Q doublecmd*.exe
@del /Q doublecmd*.old
@echo Remove generated help files
@del /Q doc\en\dev-help\*.*
@echo Clean up tools output directories
@del /Q /S tools\lib\*.*
@del /Q tools\extractdwrflnfo.exe
@echo Clean up plugins output directories
@del /Q /S plugins\*.dsx
@del /Q /S plugins\*.w?x
@del /Q /S plugins\dsx\DSXLocate\lib\*.*
@del /Q /S plugins\wcx\base64\lib\*.*
@del /Q /S plugins\wcx\cpio\lib\*.*
@del /Q /S plugins\wcx\deb\lib\*.*
@del /Q /S plugins\wcx\rpm\lib\*.*
@del /Q /S plugins\wcx\sevenzip\lib\*.*
@del /Q /S plugins\wcx\torrent\lib\*.*
@del /Q /S plugins\wcx\unrar\lib\*.*
@del /Q /S plugins\wcx\zip\lib\*.*
@del /Q /S plugins\wdx\deb_wdx\lib\*.*
@del /Q /S plugins\wdx\rpm_wdx\lib\*.*
@del /Q /S plugins\wdx\audioinfo\lib\*.*
@del /Q /S plugins\wfx\ftp\lib\*.*
@del /Q /S plugins\wfx\sample\lib\*.*
@del /Q /S plugins\wlx\preview\lib\*.*
@del /Q /S plugins\wlx\richview\lib\*.*
@del /Q /S plugins\wlx\simplewlx\lib\*.*
@del /Q /S plugins\wlx\wmp\lib\*.*
@echo Remove backup files
@del /Q /S plugins\*.*~
@del /Q /S plugins\*.bak
@echo Clean up components output directories
@del /Q /S components\chsdet\lib\*.*
@del /Q /S components\kascrypt\lib\*.*
@del /Q /S components\doublecmd\lib\*.*
@del /Q /S components\gifanim\lib\*.*
@del /Q /S components\KASToolBar\lib\*.*
@del /Q /S components\multithreadprocs\lib\*.*
@del /Q /S components\viewer\lib\*.*
@del /Q /S components\synunihighlighter\lib\*.*
@del /Q /S components\virtualterminal\lib\*.*
@echo Done. doublecmd-1.1.22/clean.sh 0000755 0001750 0000144 00000002345 14743153644 014233 0 ustar alexx users #!/bin/sh
# Clean up output directories
rm -f units/*/*
# Clean up components output directories
rm -rf components/chsdet/lib/*
rm -rf components/kascrypt/lib/*
rm -rf components/doublecmd/lib/*
rm -rf components/gifanim/lib/*
rm -rf components/Image32/lib/*
rm -rf components/KASToolBar/lib/*
rm -rf components/multithreadprocs/lib/*
rm -rf components/viewer/lib/*
rm -rf components/synunihighlighter/lib/*
rm -rf components/virtualterminal/lib/*
# Clean up all temporary files
find . -iname '*.compiled' -delete
find . -iname '*.ppu' -delete
find . -iname '*.o' -delete
find plugins -iname '*.w?x' -delete
find plugins -iname '*.dsx' -delete
find plugins -iname '*.or' -delete
find plugins -iname '*.res' -not -path "*/sevenzip/src/*" -delete
find plugins -iname '*.a' -delete
rm -f src/doublecmd.res doublecmd
rm -f tools/extractdwrflnfo
rm -f plugins/wcx/unrar/lib/rarconfdlg.lfm
rm -f plugins/wcx/unrar/lib/rarlng.rsj
rm -f plugins/wcx/zip/lib/ZipConfDlg.lfm
rm -f plugins/wcx/zip/lib/ZipLng.rsj
rm -f plugins/wcx/zip/lib/abresstring.rs?
rm -f plugins/wfx/ftp/lib/FtpConfDlg.lfm
rm -f plugins/wfx/ftp/lib/ftppropdlg.lfm
rm -f plugins/wfx/samba/lib/smbauthdlg.lfm
# Remove debug files
rm -f doublecmd.zdli doublecmd.dbg
rm -rf doublecmd.dSYM
doublecmd-1.1.22/components/ 0000755 0001750 0000144 00000000000 14743153644 014773 5 ustar alexx users doublecmd-1.1.22/components/Image32/ 0000755 0001750 0000144 00000000000 14743153644 016162 5 ustar alexx users doublecmd-1.1.22/components/Image32/Image32.lpk 0000644 0001750 0000144 00000006430 14743153644 020064 0 ustar alexx users
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
doublecmd-1.1.22/components/Image32/Image32.pas 0000644 0001750 0000144 00000000616 14743153644 020061 0 ustar alexx users { This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit Image32;
{$warn 5023 off : no warning about unused units}
interface
uses
Img32.Draw, Img32.Extra, Img32.Fmt.SVG, Img32, Img32.Resamplers,
Img32.SVG.Core, Img32.SVG.Path, Img32.SVG.Reader, Img32.Text,
Img32.Transform, Img32.Vector;
implementation
end.
doublecmd-1.1.22/components/Image32/LICENSE.txt 0000644 0001750 0000144 00000002472 14743153644 020012 0 ustar alexx users Boost Software License - Version 1.0 - August 17th, 2003
Permission is hereby granted, free of charge, to any person or organization
obtaining a copy of the software and accompanying documentation covered by
this license (the "Software") to use, reproduce, display, distribute,
execute, and transmit the Software, and to prepare derivative works of the
Software, and to permit third-parties to whom the Software is furnished to
do so, all subject to the following:
The copyright notices in the Software and this entire statement, including
the above license grant, this restriction and the following disclaimer,
must be included in all copies of the Software, in whole or in part, and
all derivative works of the Software, unless such copies or derivative
works are solely in the form of machine-executable object code generated by
a source language processor.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT
SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE
FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
doublecmd-1.1.22/components/Image32/README.md 0000644 0001750 0000144 00000000225 14743153644 017440 0 ustar alexx users # Image32
A 2D graphics library written in Delphi Pascal
https://github.com/AngusJohnson/Image32
Version: 4.3+ (2022/10/16)
Author: Angus Johnson doublecmd-1.1.22/components/Image32/source/ 0000755 0001750 0000144 00000000000 14743153644 017462 5 ustar alexx users doublecmd-1.1.22/components/Image32/source/Img32.Draw.pas 0000644 0001750 0000144 00000204502 14743153644 021747 0 ustar alexx users unit Img32.Draw;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.3 *
* Date : 27 September 2022 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2021 *
* *
* Purpose : Polygon renderer for TImage32 *
* *
* License : Use, modification & distribution is subject to *
* Boost Software License Ver 1 *
* http://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
{.$DEFINE MemCheck} //for debugging only (adds a minimal cost to performance)
uses
SysUtils, Classes, Types, Math, Img32, Img32.Vector;
type
TFillRule = Img32.Vector.TFillRule;
//TGradientColor: used internally by both
//TLinearGradientRenderer and TRadialGradientRenderer
TGradientColor = record
offset: double;
color: TColor32;
end;
TArrayOfGradientColor = array of TGradientColor;
TGradientFillStyle = (gfsClamp, gfsMirror, gfsRepeat);
//TBoundsProc: Function template for TCustomRenderer.
TBoundsProc = function(dist, colorsCnt: integer): integer;
TBoundsProcD = function(dist: double; colorsCnt: integer): integer;
TImage32ChangeProc = procedure of object;
//TCustomRenderer: can accommodate pixels of any size
TCustomRenderer = class {$IFDEF ABSTRACT_CLASSES} abstract {$ENDIF}
private
fImgWidth : integer;
fImgHeight : integer;
fImgBase : Pointer;
fCurrY : integer;
fCurrLinePtr : Pointer;
fPixelSize : integer;
fChangeProc : TImage32ChangeProc;
protected
procedure NotifyChange;
function Initialize(imgBase: Pointer;
imgWidth, imgHeight, pixelSize: integer): Boolean; overload; virtual;
function Initialize(targetImage: TImage32): Boolean; overload; virtual;
function GetDstPixel(x,y: integer): Pointer;
//RenderProc: x & y refer to pixel coords in the destination image and
//where x1 is the start (and left) and x2 is the end of the render
procedure RenderProc(x1, x2, y: integer; alpha: PByte); virtual; abstract;
property ImgWidth: integer read fImgWidth;
property ImgHeight: integer read fImgHeight;
property ImgBase: Pointer read fImgBase;
property PixelSize: integer read fPixelSize;
end;
TColorRenderer = class(TCustomRenderer)
private
fAlpha: Byte;
fColor: TColor32;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
constructor Create(color: TColor32 = clNone32);
procedure SetColor(value: TColor32);
end;
TAliasedColorRenderer = class(TCustomRenderer)
private
fColor: TColor32;
protected
function Initialize(targetImage: TImage32): Boolean; override;
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
public
constructor Create(color: TColor32 = clNone32);
end;
TEraseRenderer = class(TCustomRenderer)
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
end;
TInverseRenderer = class(TCustomRenderer)
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
end;
TImageRenderer = class(TCustomRenderer)
private
fImage : TImage32;
fOffset : TPoint;
fBrushPixel : PARGB;
fLastYY : integer;
fMirrorY : Boolean;
fBoundsProc : TBoundsProc;
function GetFirstBrushPixel(x, y: integer): PARGB;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
constructor Create(tileFillStyle: TTileFillStyle = tfsRepeat;
brushImage: TImage32 = nil);
destructor Destroy; override;
procedure SetTileFillStyle(value: TTileFillStyle);
property Image: TImage32 read fImage;
property Offset: TPoint read fOffset write fOffset;
end;
//TCustomGradientRenderer is also an abstract class
TCustomGradientRenderer = class(TCustomRenderer)
private
fBoundsProc : TBoundsProc;
fGradientColors : TArrayOfGradientColor;
protected
fColors : TArrayOfColor32;
fColorsCnt : integer;
procedure SetGradientFillStyle(value: TGradientFillStyle); virtual;
public
constructor Create;
procedure SetParameters(startColor, endColor: TColor32;
gradFillStyle: TGradientFillStyle = gfsClamp); virtual;
procedure InsertColorStop(offsetFrac: double; color: TColor32);
procedure Clear;
end;
TLinearGradientRenderer = class(TCustomGradientRenderer)
private
fStartPt : TPointD;
fEndPt : TPointD;
fPerpendicOffsets: TArrayOfInteger;
fIsVert : Boolean;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
procedure SetParameters(const startPt, endPt: TPointD;
startColor, endColor: TColor32;
gradFillStyle: TGradientFillStyle = gfsClamp); reintroduce;
end;
TRadialGradientRenderer = class(TCustomGradientRenderer)
private
fCenterPt : TPointD;
fScaleX : double;
fScaleY : double;
fColors : TArrayOfColor32;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
procedure SetParameters(const focalRect: TRect;
innerColor, outerColor: TColor32;
gradientFillStyle: TGradientFillStyle = gfsClamp); reintroduce;
end;
TSvgRadialGradientRenderer = class(TCustomGradientRenderer)
private
fA, fB : double;
fAA, fBB : double;
fCenterPt : TPointD;
fFocusPt : TPointD;
fBoundsProcD : TBoundsProcD;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
procedure SetParameters(const ellipseRect: TRect;
const focus: TPoint; innerColor, outerColor: TColor32;
gradientFillStyle: TGradientFillStyle = gfsClamp); reintroduce;
end;
//Barycentric rendering colorizes inside triangles
TBarycentricRenderer = class(TCustomRenderer)
private
a: TPointD;
c1, c2, c3: TARGB;
v0, v1: TPointD;
d00, d01, d11, invDenom: double;
function GetColor(const pt: TPointD): TColor32;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
public
procedure SetParameters(const a, b, c: TPointD; c1, c2, c3: TColor32);
end;
///////////////////////////////////////////////////////////////////////////
// DRAWING FUNCTIONS
///////////////////////////////////////////////////////////////////////////
procedure DrawPoint(img: TImage32; const pt: TPointD;
radius: double; color: TColor32); overload;
procedure DrawPoint(img: TImage32; const pt: TPointD;
radius: double; renderer: TCustomRenderer); overload;
procedure DrawPoint(img: TImage32; const points: TPathD;
radius: double; color: TColor32); overload;
procedure DrawPoint(img: TImage32; const paths: TPathsD;
radius: double; color: TColor32); overload;
procedure DrawLine(img: TImage32;
const pt1, pt2: TPointD; lineWidth: double; color: TColor32); overload;
procedure DrawLine(img: TImage32;
const line: TPathD; lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
miterLimit: double = 2); overload;
procedure DrawLine(img: TImage32;
const line: TPathD; lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
miterLimit: double = 2); overload;
procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
miterLimit: double = 2); overload;
procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
miterLimit: double = 2); overload;
procedure DrawInvertedLine(img: TImage32;
const line: TPathD; lineWidth: double;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawInvertedLine(img: TImage32;
const lines: TPathsD; lineWidth: double;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawDashedLine(img: TImage32; const line: TPathD;
dashPattern: TArrayOfInteger; patternOffset: PDouble;
lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
dashPattern: TArrayOfInteger; patternOffset: PDouble;
lineWidth: double; color: TColor32; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawDashedLine(img: TImage32; const line: TPathD;
dashPattern: TArrayOfInteger; patternOffset: PDouble;
lineWidth: double; renderer: TCustomRenderer; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
dashPattern: TArrayOfInteger; patternOffset: PDouble;
lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawInvertedDashedLine(img: TImage32;
const line: TPathD; dashPattern: TArrayOfInteger;
patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawInvertedDashedLine(img: TImage32;
const lines: TPathsD; dashPattern: TArrayOfInteger;
patternOffset: PDouble; lineWidth: double;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawPolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; color: TColor32); overload;
procedure DrawPolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; renderer: TCustomRenderer); overload;
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32); overload;
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; renderer: TCustomRenderer); overload;
// 'Clear Type' text rendering is quite useful for low resolution
// displays (96 ppi). However it's of little to no benefit on higher
// resolution displays and becomes unnecessary overhead. See also:
// https://en.wikipedia.org/wiki/Subpixel_rendering
// https://www.grc.com/ctwhat.htm
// https://www.grc.com/cttech.htm
procedure DrawPolygon_ClearType(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32; backColor: TColor32 = clWhite32);
///////////////////////////////////////////////////////////////////////////
// MISCELLANEOUS FUNCTIONS
///////////////////////////////////////////////////////////////////////////
procedure ErasePolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule); overload;
procedure ErasePolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule); overload;
//Both DrawBoolMask and DrawAlphaMask require
//'mask' length to equal 'img' width * height
procedure DrawBoolMask(img: TImage32;
const mask: TArrayOfByte; color: TColor32 = clBlack32);
procedure DrawAlphaMask(img: TImage32;
const mask: TArrayOfByte; color: TColor32 = clBlack32);
procedure Rasterize(const paths: TPathsD;
const clipRec: TRect; fillRule: TFillRule; renderer: TCustomRenderer);
implementation
{$IFDEF MemCheck}
resourcestring
sMemCheckError = 'Img32.Draw: Memory allocation error';
{$ENDIF}
type
//A horizontal scanline contains any number of line fragments. A fragment
//can be a number of pixels wide but it can't be more than one pixel high.
TFragment = record
botX, topX, dy, dydx: double;
end;
TFragmentArray = array[0 .. (Maxint div SizeOf(TFragment)) -1] of TFragment;
PFragments = ^TFragmentArray;
PFragment = ^TFragment;
TScanLine = record
Y: integer;
minX, maxX: integer;
fragCnt: integer;
{$IFDEF MemCheck} total: integer; {$ENDIF}
fragments: PFragments;
end;
PScanline = ^TScanline;
TArrayOfScanline = array of TScanline;
//------------------------------------------------------------------------------
// ApplyClearType (see DrawPolygon_ClearType below)
//------------------------------------------------------------------------------
type
PArgbs = ^TArgbs;
TArgbs = array [0.. (Maxint div SizeOf(TARGB)) -1] of TARGB;
procedure ApplyClearType(img: TImage32; textColor: TColor32 = clBlack32;
bkColor: TColor32 = clWhite32);
const
centerWeighting = 5; //0 <= centerWeighting <= 25
var
h, w: integer;
src, dst: PARGB;
srcArr: PArgbs;
fgColor: TARGB absolute textColor;
bgColor: TARGB absolute bkColor;
diff_R, diff_G, diff_B: integer;
bg8_R, bg8_G, bg8_B: integer;
rowBuffer: TArrayOfARGB;
primeTbl, nearTbl, FarTbl: PByteArray;
begin
// Precondition: the background to text drawn onto 'img' must be transparent
// 85 + (2 * 57) + (2 * 28) == 255
primeTbl := PByteArray(@MulTable[85 + centerWeighting *2]);
nearTbl := PByteArray(@MulTable[57]);
farTbl := PByteArray(@MulTable[28 - centerWeighting]);
SetLength(rowBuffer, img.Width +4);
for h := 0 to img.Height -1 do
begin
//each row of the image is copied into a temporary buffer ...
//noting that while 'dst' (img.Pixels) is initially the source
//it will later be destination (during image compression).
dst := PARGB(@img.Pixels[h * img.Width]);
src := PARGB(@rowBuffer[2]);
Move(dst^, src^, img.Width * SizeOf(TColor32));
srcArr := PArgbs(rowBuffer);
//using this buffer compress the image ...
w := 2;
while w < img.Width do
begin
dst.R := primeTbl[srcArr[w].A] +
nearTbl[srcArr[w-1].A] + farTbl[srcArr[w-2].A] +
nearTbl[srcArr[w+1].A] + farTbl[srcArr[w+2].A];
inc(w);
dst.G := primeTbl[srcArr[w].A] +
nearTbl[srcArr[w-1].A] + farTbl[srcArr[w-2].A] +
nearTbl[srcArr[w+1].A] + farTbl[srcArr[w+2].A];
inc(w);
dst.B := primeTbl[srcArr[w].A] +
nearTbl[srcArr[w-1].A] + farTbl[srcArr[w-2].A] +
nearTbl[srcArr[w+1].A] + farTbl[srcArr[w+2].A];
inc(w);
dst.A := 255;
inc(dst);
end;
end;
//Following compression the right 2/3 of the image is redundant
img.Crop(Types.Rect(0,0, img.Width div 3, img.Height));
//currently text is white and the background is black
//so blend in the text and background colors ...
diff_R := fgColor.R - bgColor.R;
diff_G := fgColor.G - bgColor.G;
diff_B := fgColor.B - bgColor.B;
bg8_R := bgColor.R shl 8;
bg8_G := bgColor.G shl 8;
bg8_B := bgColor.B shl 8;
dst := PARGB(img.PixelBase);
for h := 0 to img.Width * img.Height -1 do
begin
if dst.R = 0 then
dst.Color := bkColor
else
begin
//blend front (text) and background colors ...
dst.R := (bg8_R + diff_R * dst.R) shr 8;
dst.G := (bg8_G + diff_G * dst.G) shr 8;
dst.B := (bg8_B + diff_B * dst.B) shr 8;
end;
inc(dst);
end;
end;
//------------------------------------------------------------------------------
// Other miscellaneous functions
//------------------------------------------------------------------------------
////__Trunc: An efficient Trunc() algorithm (ie rounds toward zero)
//function __Trunc(val: double): integer; {$IFDEF INLINE} inline; {$ENDIF}
//var
// exp: integer;
// i64: UInt64 absolute val;
//begin
// //https://en.wikipedia.org/wiki/Double-precision_floating-point_format
// Result := 0;
// if i64 = 0 then Exit;
// exp := Integer(Cardinal(i64 shr 52) and $7FF) - 1023;
// //nb: when exp == 1024 then val == INF or NAN.
// if exp < 0 then Exit;
// Result := ((i64 and $1FFFFFFFFFFFFF) shr (52-exp)) or (1 shl exp);
// if val < 0 then Result := -Result;
//end;
//------------------------------------------------------------------------------
function ClampByte(val: double): byte; {$IFDEF INLINE} inline; {$ENDIF}
begin
if val < 0 then result := 0
else if val > 255 then result := 255
else result := Round(val);
end;
//------------------------------------------------------------------------------
function GetPixel(current: PARGB; delta: integer): PARGB;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result := current;
inc(Result, delta);
end;
//------------------------------------------------------------------------------
function ReverseColors(const colors: TArrayOfGradientColor): TArrayOfGradientColor;
var
i, highI: integer;
begin
highI := High(colors);
SetLength(result, highI +1);
for i := 0 to highI do
begin
result[i].color := colors[highI -i].color;
result[i].offset := 1 - colors[highI -i].offset;
end;
end;
//------------------------------------------------------------------------------
procedure SwapColors(var color1, color2: TColor32);
var
c: TColor32;
begin
c := color1;
color1 := color2;
color2 := c;
end;
//------------------------------------------------------------------------------
procedure SwapPoints(var point1, point2: TPoint); overload;
var
pt: TPoint;
begin
pt := point1;
point1 := point2;
point2 := pt;
end;
//------------------------------------------------------------------------------
procedure SwapPoints(var point1, point2: TPointD); overload;
var
pt: TPointD;
begin
pt := point1;
point1 := point2;
point2 := pt;
end;
//------------------------------------------------------------------------------
function ClampQ(q, endQ: integer): integer;
begin
if q < 0 then result := 0
else if q >= endQ then result := endQ -1
else result := q;
end;
//------------------------------------------------------------------------------
function ClampD(d: double; colorCnt: integer): integer;
begin
dec(colorCnt);
if d < 0 then result := 0
else if d >= 1 then result := colorCnt
else result := Round(d * colorCnt);
end;
//------------------------------------------------------------------------------
function MirrorQ(q, endQ: integer): integer;
begin
result := q mod endQ;
if (result < 0) then result := -result;
if Odd(q div endQ) then
result := (endQ -1) - result;
end;
//------------------------------------------------------------------------------
function MirrorD(d: double; colorCnt: integer): integer;
begin
dec(colorCnt);
if Odd(Round(d)) then
result := Round((1 - frac(d)) * colorCnt) else
result := Round(frac(d) * colorCnt);
end;
//------------------------------------------------------------------------------
function RepeatQ(q, endQ: integer): integer;
begin
if (q < 0) or (q >= endQ) then
begin
endQ := Abs(endQ);
result := q mod endQ;
if result < 0 then inc(result, endQ);
end
else result := q;
end;
//------------------------------------------------------------------------------
function SoftRptQ(q, endQ: integer): integer;
begin
if (q < 0) then
result := endQ + (q mod endQ) else
result := (q mod endQ);
if result = 0 then result := endQ div 2;
end;
//------------------------------------------------------------------------------
function RepeatD(d: double; colorCnt: integer): integer;
begin
dec(colorCnt);
if (d < 0) then
result := Round((1 + frac(d)) * colorCnt) else
result := Round(frac(d) * colorCnt);
end;
//------------------------------------------------------------------------------
function BlendColorUsingMask(bgColor, fgColor: TColor32; mask: Byte): TColor32;
var
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
res: TARGB absolute Result;
R, invR: PByteArray;
begin
if fg.A = 0 then
begin
Result := bgColor;
res.A := MulBytes(res.A, not mask);
end
else if bg.A = 0 then
begin
Result := fgColor;
res.A := MulBytes(res.A, mask);
end
else if (mask = 0) then
Result := bgColor
else if (mask = 255) then
Result := fgColor
else
begin
R := PByteArray(@MulTable[mask]);
InvR := PByteArray(@MulTable[not mask]);
res.A := R[fg.A] + InvR[bg.A];
res.R := R[fg.R] + InvR[bg.R];
res.G := R[fg.G] + InvR[bg.G];
res.B := R[fg.B] + InvR[bg.B];
end;
end;
//------------------------------------------------------------------------------
//MakeColorGradient: using the supplied array of TGradientColor,
//create an array of TColor32 of the specified length
function MakeColorGradient(const gradColors: TArrayOfGradientColor;
len: integer): TArrayOfColor32;
var
i,j, lenC: integer;
dist, offset1, offset2, step, pos: double;
color1, color2: TColor32;
begin
lenC := length(gradColors);
if (len = 0) or (lenC < 2) then Exit;
SetLength(result, len);
color2 := gradColors[0].color;
result[0] := color2;
if len = 1 then Exit;
step := 1/(len-1);
pos := step;
offset2 := 0;
i := 1; j := 1;
repeat
offset1 := offset2;
offset2 := gradColors[i].offset;
dist := offset2 - offset1;
color1 := color2;
color2 := gradColors[i].color;
while (pos <= dist) and (j < len) do
begin
result[j] := BlendColorUsingMask(color1, color2, Round(pos/dist * 255));
inc(j);
pos := pos + step;
end;
pos := pos - dist;
inc(i);
until i = lenC;
if j < len then result[j] := result[j-1];
end;
//------------------------------------------------------------------------------
// Rasterize() support functions
//------------------------------------------------------------------------------
procedure AllocateScanlines(const polygons: TPathsD;
var scanlines: TArrayOfScanline; clipBottom, clipRight: integer);
var
i,j, highI, highJ: integer;
y1, y2: integer;
psl: PScanline;
begin
//first count how often each edge intersects with each horizontal scanline
for i := 0 to high(polygons) do
begin
highJ := high(polygons[i]);
if highJ < 2 then continue;
y1 := Round(polygons[i][highJ].Y);
for j := 0 to highJ do
begin
y2 := Round(polygons[i][j].Y);
if y1 < y2 then
begin
//descending (but ignore edges outside the clipping range)
if (y2 >= 0) and (y1 <= clipBottom) then
begin
if (y1 > 0) and (y1 <= clipBottom) then
dec(scanlines[y1 -1].fragCnt);
if y2 >= clipBottom then
inc(scanlines[clipBottom].fragCnt) else
inc(scanlines[y2].fragCnt);
end;
end else
begin
//ascending (but ignore edges outside the clipping range)
if (y1 >= 0) and (y2 <= clipBottom) then
begin
if (y2 > 0) then
dec(scanlines[y2 -1].fragCnt);
if y1 >= clipBottom then
inc(scanlines[clipBottom].fragCnt) else
inc(scanlines[y1].fragCnt);
end;
end;
y1 := y2;
end;
end;
//convert 'count' accumulators into real counts and allocate storage
j := 0;
highI := high(scanlines);
psl := @scanlines[highI];
//'fragments' is a pointer and not a dynamic array because
//dynamic arrays are zero initialized (hence slower than GetMem).
for i := highI downto 0 do
begin
inc(j, psl.fragCnt); //nb: psl.fragCnt may be < 0 here!
if j > 0 then
GetMem(psl.fragments, j * SizeOf(TFragment));
{$IFDEF MemCheck} psl.total := j; {$ENDIF}
psl.fragCnt := 0; //reset for later
psl.minX := clipRight;
psl.maxX := 0;
psl.Y := i;
dec(psl);
end;
end;
//------------------------------------------------------------------------------
procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD;
const scanlines: TArrayOfScanline; const clipRec: TRect);
var
x,y, dx,dy, absDx, dydx, dxdy: double;
i, scanlineY, maxY, maxX: integer;
psl: PScanLine;
pFrag: PFragment;
bot, top: TPointD;
begin
dy := pt1.Y - pt2.Y;
dx := pt2.X - pt1.X;
RectWidthHeight(clipRec, maxX, maxY);
absDx := abs(dx);
if dy > 0 then
begin
//ASCENDING EDGE (+VE WINDING DIR)
if dy < 0.0001 then Exit; //ignore near horizontals
bot := pt1; top := pt2;
//exclude edges that are completely outside the top or bottom clip region
if (top.Y >= maxY) or (bot.Y <= 0) then Exit;
end else
begin
//DESCENDING EDGE (-VE WINDING DIR)
if dy > -0.0001 then Exit; //ignore near horizontals
bot := pt2; top := pt1;
//exclude edges that are completely outside the top or bottom clip region
if (top.Y >= maxY) or (bot.Y <= 0) then Exit;
end;
if absDx < 0.000001 then
begin
//VERTICAL EDGE
top.X := bot.X; //this circumvents v. rare rounding issues.
//exclude vertical edges that are outside the right clip region
//but still update maxX for each scanline the edge passes
if bot.X > maxX then
begin
for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(top.Y)) do
scanlines[i].maxX := maxX;
Exit;
end;
dxdy := 0;
if dy > 0 then dydx := 1 else dydx := -1;
end else
begin
dxdy := dx/dy;
dydx := dy/absDx;
end;
//TRIM EDGES THAT CROSS CLIPPING BOUNDARIES (EXCEPT THE LEFT BOUNDARY)
if bot.X >= maxX then
begin
if top.X >= maxX then
begin
for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(top.Y)) do
scanlines[i].maxX := maxX;
Exit;
end;
//here the edge must be oriented bottom-right to top-left
y := bot.Y - (bot.X - maxX) * Abs(dydx);
for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(y)) do
scanlines[i].maxX := maxX;
bot.Y := y;
if bot.Y <= 0 then Exit;
bot.X := maxX;
end
else if top.X > maxX then
begin
//here the edge must be oriented bottom-left to top-right
y := top.Y + (top.X - maxX) * Abs(dydx);
for i := Min(maxY, Round(y)) downto Max(0, Round(top.Y)) do
scanlines[i].maxX := maxX;
top.Y := y;
if top.Y >= maxY then Exit;
top.X := maxX;
end;
if bot.Y > maxY then
begin
bot.X := bot.X + dxdy * (bot.Y - maxY);
if (bot.X > maxX) then Exit; //nb: no clipping on the left
bot.Y := maxY;
end;
if top.Y < 0 then
begin
top.X := top.X + (dxdy * top.Y);
if (top.X > maxX) then Exit; //nb: no clipping on the left
top.Y := 0;
end;
//SPLIT THE EDGE INTO MULTIPLE SCANLINE FRAGMENTS
scanlineY := Round(bot.Y);
if bot.Y = scanlineY then dec(scanlineY);
//at the lower-most extent of the edge 'split' the first fragment
if scanlineY < 0 then Exit;
psl := @scanlines[scanlineY];
if not assigned(psl.fragments) then Exit; //a very rare event
{$IFDEF MemCheck}
if psl.fragCnt = psl.total then raise Exception.Create(sMemCheckError);
{$ENDIF}
pFrag := @psl.fragments[psl.fragCnt];
inc(psl.fragCnt);
pFrag.botX := bot.X;
if scanlineY <= top.Y then
begin
//the whole edge is within 1 scanline
pFrag.topX := top.X;
pFrag.dy := bot.Y - top.Y;
pFrag.dydx := dydx;
Exit;
end;
x := bot.X + (bot.Y - scanlineY) * dxdy;
pFrag.topX := x;
pFrag.dy := bot.Y - scanlineY;
pFrag.dydx := dydx;
//'split' subsequent fragments until the top fragment
dec(psl);
while psl.Y > top.Y do
begin
{$IFDEF MemCheck}
if psl.fragCnt = psl.total then raise Exception.Create(sMemCheckError);
{$ENDIF}
pFrag := @psl.fragments[psl.fragCnt];
inc(psl.fragCnt);
pFrag.botX := x;
x := x + dxdy;
pFrag.topX := x;
pFrag.dy := 1;
pFrag.dydx := dydx;
dec(psl);
end;
//and finally the top fragment
{$IFDEF MemCheck}
if psl.fragCnt = psl.total then raise Exception.Create(sMemCheckError);
{$ENDIF}
pFrag := @psl.fragments[psl.fragCnt];
inc(psl.fragCnt);
pFrag.botX := x;
pFrag.topX := top.X;
pFrag.dy := psl.Y + 1 - top.Y;
pFrag.dydx := dydx;
end;
//------------------------------------------------------------------------------
procedure InitializeScanlines(var polygons: TPathsD;
const scanlines: TArrayOfScanline; const clipRec: TRect);
var
i,j, highJ: integer;
pt1, pt2: PPointD;
begin
for i := 0 to high(polygons) do
begin
highJ := high(polygons[i]);
if highJ < 2 then continue;
pt1 := @polygons[i][highJ];
pt2 := @polygons[i][0];
for j := 0 to highJ do
begin
SplitEdgeIntoFragments(pt1^, pt2^, scanlines, clipRec);
pt1 := pt2;
inc(pt2);
end;
end;
end;
//------------------------------------------------------------------------------
procedure ProcessScanlineFragments(var scanline: TScanLine;
var buffer: TArrayOfDouble);
var
i,j, leftXi,rightXi: integer;
fracX, yy, q, windDir: double;
pd: PDouble;
frag: PFragment;
begin
frag := @scanline.fragments[0];
for i := 1 to scanline.fragCnt do
begin
if frag.botX > frag.topX then
begin
//just swapping botX and topX simplifies code
q := frag.botX;
frag.botX := frag.topX;
frag.topX := q;
end;
leftXi := Max(0, Round(frag.botX));
rightXi := Max(0, Round(frag.topX));
if (leftXi = rightXi) then
begin
if frag.dydx < 0 then windDir := -1.0 else windDir := 1.0;
//the fragment is only one pixel wide
if leftXi < scanline.minX then
scanline.minX := leftXi;
if rightXi > scanline.maxX then
scanline.maxX := rightXi;
pd := @buffer[leftXi];
if (frag.botX <= 0) then
begin
pd^ := pd^ + frag.dy * windDir;
end else
begin
q := (frag.botX + frag.topX) * 0.5 - leftXi;
pd^ := pd^ + (1-q) * frag.dy * windDir;
inc(pd);
pd^ := pd^ + q * frag.dy * windDir;
end;
end else
begin
if leftXi < scanline.minX then
scanline.minX := leftXi;
if rightXi > scanline.maxX then
scanline.maxX := rightXi;
pd := @buffer[leftXi];
//left pixel
fracX := leftXi + 1 - frag.botX;
yy := frag.dydx * fracX;
q := fracX * yy * 0.5;
pd^ := pd^ + q;
q := yy - q;
inc(pd);
//middle pixels
for j := leftXi +1 to rightXi -1 do
begin
pd^ := pd^ + q + frag.dydx * 0.5;
q := frag.dydx * 0.5;
inc(pd);
end;
//right pixel
fracX := frag.topX - rightXi;
yy := fracX * frag.dydx;
pd^ := pd^ + q + (1 - fracX * 0.5) * yy;
inc(pd);
//overflow
pd^ := pd^ + fracX * 0.5 * yy;
end;
inc(frag);
end;
end;
//------------------------------------------------------------------------------
{$IFNDEF TROUNDINGMODE}
type
TRoundingMode = {$IFNDEF FPC}Math.{$ENDIF}TFPURoundingMode;
{$ENDIF}
procedure Rasterize(const paths: TPathsD; const clipRec: TRect;
fillRule: TFillRule; renderer: TCustomRenderer);
var
i,j, xli,xri, maxW, maxH, aa: integer;
clipRec2: TRect;
paths2: TPathsD;
accum: double;
windingAccum: TArrayOfDouble;
byteBuffer: TArrayOfByte;
scanlines: TArrayOfScanline;
scanline: PScanline;
savedRoundMode: TRoundingMode;
begin
//See also https://nothings.org/gamedev/rasterize/
if not assigned(renderer) then Exit;
Types.IntersectRect(clipRec2, clipRec, GetBounds(paths));
if IsEmptyRect(clipRec2) then Exit;
paths2 := OffsetPath(paths, -clipRec2.Left, -clipRec2.Top);
//Delphi's Round() function is *much* faster than its Trunc function, and
//it's even a little faster than the __Trunc function above (except when
//the FastMM4 memory manager is enabled.)
savedRoundMode := SetRoundMode(rmDown);
RectWidthHeight(clipRec2, maxW, maxH);
SetLength(scanlines, maxH +1);
SetLength(windingAccum, maxW +2);
AllocateScanlines(paths2, scanlines, maxH, maxW-1);
InitializeScanlines(paths2, scanlines, clipRec2);
SetLength(byteBuffer, maxW);
if byteBuffer = nil then Exit;
scanline := @scanlines[0];
for i := 0 to high(scanlines) do
begin
if scanline.fragCnt = 0 then
begin
FreeMem(scanline.fragments);
inc(scanline);
Continue;
end;
//process each scanline to fill the winding count accumulation buffer
ProcessScanlineFragments(scanline^, windingAccum);
//it's faster to process only the modified sub-array of windingAccum
xli := scanline.minX;
xri := Min(maxW -1, scanline.maxX +1);
FillChar(byteBuffer[xli], xri - xli +1, 0);
//a 25% weighting has been added to the alpha channel to minimize any
//background bleed-through where polygons join with a common edge.
accum := 0; //winding count accumulator
for j := xli to xri do
begin
accum := accum + windingAccum[j];
case fillRule of
frEvenOdd:
begin
aa := Round(Abs(accum) * 1275) mod 2550; // *5
if aa > 1275 then
byteBuffer[j] := Min(255, (2550 - aa) shr 2) else // /4
byteBuffer[j] := Min(255, aa shr 2); // /4
end;
frNonZero:
begin
byteBuffer[j] := Min(255, Round(Abs(accum) * 318));
end;
{$IFDEF REVERSE_ORIENTATION}
frPositive:
{$ELSE}
frNegative:
{$ENDIF}
begin
if accum > 0.002 then
byteBuffer[j] := Min(255, Round(accum * 318));
end;
{$IFDEF REVERSE_ORIENTATION}
frNegative:
{$ELSE}
frPositive:
{$ENDIF}
begin
if accum < -0.002 then
byteBuffer[j] := Min(255, Round(-accum * 318));
end;
end;
end;
renderer.RenderProc(clipRec2.Left + xli, clipRec2.Left + xri,
clipRec2.Top + i, @byteBuffer[xli]);
//cleanup and deallocate memory
FillChar(windingAccum[xli], (xri - xli +1) * sizeOf(Double), 0);
FreeMem(scanline.fragments);
inc(scanline);
end;
SetRoundMode(savedRoundMode);
end;
//------------------------------------------------------------------------------
// TAbstractRenderer
//------------------------------------------------------------------------------
function TCustomRenderer.Initialize(imgBase: Pointer;
imgWidth, imgHeight, pixelSize: integer): Boolean;
begin
fImgBase := imgBase;
fImgWidth := ImgWidth;
fImgHeight := ImgHeight;
fPixelSize := pixelSize;
fCurrLinePtr := fImgBase;
fCurrY := 0;
result := true;
end;
//------------------------------------------------------------------------------
procedure TCustomRenderer.NotifyChange;
begin
if assigned(fChangeProc) then fChangeProc;
end;
//------------------------------------------------------------------------------
type THackedImage32 = class(TImage32); //exposes protected Changed method.
function TCustomRenderer.Initialize(targetImage: TImage32): Boolean;
begin
fChangeProc := THackedImage32(targetImage).Changed;
with targetImage do
result := Initialize(PixelBase, Width, Height, SizeOf(TColor32));
end;
//------------------------------------------------------------------------------
function TCustomRenderer.GetDstPixel(x, y: integer): Pointer;
begin
if (y <> fCurrY) then
begin
fCurrY := y;
fCurrLinePtr := fImgBase;
inc(PByte(fCurrLinePtr), fCurrY * fImgWidth * fPixelSize);
end;
Result := fCurrLinePtr;
inc(PByte(Result), x * fPixelSize);
end;
//------------------------------------------------------------------------------
// TColorRenderer
//------------------------------------------------------------------------------
constructor TColorRenderer.Create(color: TColor32 = clNone32);
begin
if color <> clNone32 then SetColor(color);
end;
//------------------------------------------------------------------------------
function TColorRenderer.Initialize(targetImage: TImage32): Boolean;
begin
//there's no point rendering if the color is fully transparent
result := (fAlpha > 0) and inherited Initialize(targetImage);
end;
//------------------------------------------------------------------------------
procedure TColorRenderer.SetColor(value: TColor32);
begin
fColor := value and $FFFFFF;
fAlpha := GetAlpha(value);
end;
//------------------------------------------------------------------------------
procedure TColorRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dst: PColor32;
begin
dst := GetDstPixel(x1,y);
for i := x1 to x2 do
begin
//BlendToAlpha is marginally slower than BlendToOpaque but it's used
//here because it's universally applicable.
//Ord() is used here because very old compilers define PByte as a PChar
if Ord(alpha^) > 1 then
dst^ := BlendToAlpha(dst^, ((Ord(alpha^) * fAlpha) shr 8) shl 24 or fColor);
inc(dst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TAliasedColorRenderer
//------------------------------------------------------------------------------
constructor TAliasedColorRenderer.Create(color: TColor32 = clNone32);
begin
fColor := color;
end;
//------------------------------------------------------------------------------
function TAliasedColorRenderer.Initialize(targetImage: TImage32): Boolean;
begin
//there's no point rendering if the color is fully transparent
result := (GetAlpha(fColor) > 0) and
inherited Initialize(targetImage);
end;
//------------------------------------------------------------------------------
procedure TAliasedColorRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dst: PColor32;
begin
dst := GetDstPixel(x1,y);
for i := x1 to x2 do
begin
if Ord(alpha^) > 127 then dst^ := fColor; //ie no blending
inc(dst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TBrushImageRenderer
//------------------------------------------------------------------------------
constructor TImageRenderer.Create(tileFillStyle: TTileFillStyle;
brushImage: TImage32);
begin
fImage := TImage32.Create(brushImage);
SetTileFillStyle(tileFillStyle);
end;
//------------------------------------------------------------------------------
destructor TImageRenderer.Destroy;
begin
fImage.Free;
inherited;
end;
//------------------------------------------------------------------------------
procedure TImageRenderer.SetTileFillStyle(value: TTileFillStyle);
begin
case value of
tfsRepeat: fBoundsProc := RepeatQ;
tfsMirrorHorz: fBoundsProc := MirrorQ;
tfsMirrorVert: fBoundsProc := RepeatQ;
tfsRotate180 : fBoundsProc := MirrorQ;
end;
fMirrorY := value in [tfsMirrorVert, tfsRotate180];
end;
//------------------------------------------------------------------------------
function TImageRenderer.Initialize(targetImage: TImage32): Boolean;
begin
result := inherited Initialize(targetImage) and (not fImage.IsEmpty);
if not result then Exit;
fLastYY := 0;
fBrushPixel := PARGB(fImage.PixelBase);
end;
//------------------------------------------------------------------------------
procedure TImageRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
pDst: PColor32;
pBrush: PARGB;
begin
pDst := GetDstPixel(x1,y);
dec(x1, fOffset.X);
dec(x2, fOffset.X);
dec(y, fOffset.Y);
pBrush := GetFirstBrushPixel(x1, y);
for i := x1 to x2 do
begin
pDst^ := BlendToAlpha(pDst^,
MulBytes(pBrush.A, Ord(alpha^)) shl 24 or (pBrush.Color and $FFFFFF));
inc(pDst); inc(alpha);
pBrush := GetPixel(fBrushPixel, fBoundsProc(i, fImage.Width));
end;
end;
//------------------------------------------------------------------------------
function TImageRenderer.GetFirstBrushPixel(x, y: integer): PARGB;
begin
if fMirrorY then
y := MirrorQ(y, fImage.Height) else
y := RepeatQ(y, fImage.Height);
if y <> fLastYY then
begin
fBrushPixel := PARGB(fImage.PixelRow[y]);
fLastYY := y;
end;
x := fBoundsProc(x, fImage.Width);
result := GetPixel(fBrushPixel, x);
end;
//------------------------------------------------------------------------------
// TGradientRenderer
//------------------------------------------------------------------------------
constructor TCustomGradientRenderer.Create;
begin
fBoundsProc := ClampQ; //default proc
end;
//------------------------------------------------------------------------------
procedure TCustomGradientRenderer.Clear;
begin
fGradientColors := nil;
fColors := nil;
end;
//------------------------------------------------------------------------------
procedure TCustomGradientRenderer.SetGradientFillStyle(value: TGradientFillStyle);
begin
case value of
gfsClamp: fBoundsProc := ClampQ;
gfsMirror: fBoundsProc := MirrorQ;
else fBoundsProc := RepeatQ;
end;
end;
//------------------------------------------------------------------------------
procedure TCustomGradientRenderer.SetParameters(startColor, endColor: TColor32;
gradFillStyle: TGradientFillStyle = gfsClamp);
begin
SetGradientFillStyle(gradFillStyle);
//reset gradient colors if perviously set
SetLength(fGradientColors, 2);
fGradientColors[0].offset := 0;
fGradientColors[0].color := startColor;
fGradientColors[1].offset := 1;
fGradientColors[1].color := endColor;
end;
//------------------------------------------------------------------------------
procedure TCustomGradientRenderer.InsertColorStop(offsetFrac: double; color: TColor32);
var
i, len: integer;
gradColor: TGradientColor;
begin
len := Length(fGradientColors);
//colorstops can only be inserted after calling SetParameters
if len = 0 then Exit;
if offsetFrac < 0 then offsetFrac := 0
else if offsetFrac > 1 then offsetFrac := 1;
if offsetFrac = 0 then
begin
fGradientColors[0].color := color;
Exit;
end
else if offsetFrac = 1 then
begin
fGradientColors[len -1].color := color;
Exit;
end;
gradColor.offset := offsetFrac;
gradColor.color := color;
i := 1;
while (i < len-1) and
(fGradientColors[i].offset <= offsetFrac) do inc(i);
SetLength(fGradientColors, len +1);
Move(fGradientColors[i],
fGradientColors[i+1], (len -i) * SizeOf(TGradientColor));
fGradientColors[i] := gradColor;
end;
//------------------------------------------------------------------------------
// TLinearGradientRenderer
//------------------------------------------------------------------------------
procedure TLinearGradientRenderer.SetParameters(const startPt, endPt: TPointD;
startColor, endColor: TColor32; gradFillStyle: TGradientFillStyle);
begin
inherited SetParameters(startColor, endColor, gradFillStyle);
fStartPt := startPt;
fEndPt := endPt;
end;
//------------------------------------------------------------------------------
function TLinearGradientRenderer.Initialize(targetImage: TImage32): Boolean;
var
i: integer;
dx,dy, dxdy,dydx: double;
begin
result := inherited Initialize(targetImage) and assigned(fGradientColors);
if not result then Exit;
if abs(fEndPt.Y - fStartPt.Y) > abs(fEndPt.X - fStartPt.X) then
begin
//gradient > 45 degrees
if (fEndPt.Y < fStartPt.Y) then
begin
fGradientColors := ReverseColors(fGradientColors);
SwapPoints(fStartPt, fEndPt);
end;
fIsVert := true;
dx := (fEndPt.X - fStartPt.X);
dy := (fEndPt.Y - fStartPt.Y);
dxdy := dx/dy;
fColorsCnt := Ceil(dy + dxdy * (fEndPt.X - fStartPt.X));
fColors := MakeColorGradient(fGradientColors, fColorsCnt);
//get a list of perpendicular offsets for each
SetLength(fPerpendicOffsets, ImgWidth);
//from an imaginary line that's through fStartPt and perpendicular to
//the gradient line, get a list of Y offsets for each X in image width
for i := 0 to ImgWidth -1 do
fPerpendicOffsets[i] := Round(dxdy * (fStartPt.X - i) + fStartPt.Y);
end
else //gradient <= 45 degrees
begin
if (fEndPt.X = fStartPt.X) then
begin
Result := false;
Exit;
end;
if (fEndPt.X < fStartPt.X) then
begin
fGradientColors := ReverseColors(fGradientColors);
SwapPoints(fStartPt, fEndPt);
end;
fIsVert := false;
dx := (fEndPt.X - fStartPt.X);
dy := (fEndPt.Y - fStartPt.Y);
dydx := dy/dx; //perpendicular slope
fColorsCnt := Ceil(dx + dydx * (fEndPt.Y - fStartPt.Y));
fColors := MakeColorGradient(fGradientColors, fColorsCnt);
SetLength(fPerpendicOffsets, ImgHeight);
//from an imaginary line that's through fStartPt and perpendicular to
//the gradient line, get a list of X offsets for each Y in image height
for i := 0 to ImgHeight -1 do
fPerpendicOffsets[i] := Round(dydx * (fStartPt.Y - i) + fStartPt.X);
end;
end;
//------------------------------------------------------------------------------
procedure TLinearGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i, off: integer;
pDst: PColor32;
color: TARGB;
begin
pDst := GetDstPixel(x1,y);
for i := x1 to x2 do
begin
if fIsVert then
begin
//when fIsVert = true, fPerpendicOffsets is an array of Y for each X
off := fPerpendicOffsets[i];
color.Color := fColors[fBoundsProc(y - off, fColorsCnt)];
end else
begin
//when fIsVert = false, fPerpendicOffsets is an array of X for each Y
off := fPerpendicOffsets[y];
color.Color := fColors[fBoundsProc(i - off, fColorsCnt)];
end;
pDst^ := BlendToAlpha(pDst^,
MulBytes(color.A, Ord(alpha^)) shl 24 or (color.Color and $FFFFFF));
inc(pDst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TRadialGradientRenderer
//------------------------------------------------------------------------------
function TRadialGradientRenderer.Initialize(targetImage: TImage32): Boolean;
begin
result := inherited Initialize(targetImage) and (fColorsCnt > 1);
if result then
fColors := MakeColorGradient(fGradientColors, fColorsCnt);
end;
//------------------------------------------------------------------------------
procedure TRadialGradientRenderer.SetParameters(const focalRect: TRect;
innerColor, outerColor: TColor32;
gradientFillStyle: TGradientFillStyle);
var
w,h: integer;
radX,radY: double;
begin
inherited SetParameters(innerColor, outerColor, gradientFillStyle);
fColorsCnt := 0;
if IsEmptyRect(focalRect) then Exit;
fCenterPt.X := (focalRect.Left + focalRect.Right) * 0.5;
fCenterPt.Y := (focalRect.Top + focalRect.Bottom) * 0.5;
RectWidthHeight(focalRect, w, h);
radX := w * 0.5;
radY := h * 0.5;
if radX >= radY then
begin
fScaleX := 1;
fScaleY := radX/radY;
fColorsCnt := Ceil(radX) +1;
end else
begin
fScaleX := radY/radX;
fScaleY := 1;
fColorsCnt := Ceil(radY) +1;
end;
end;
//------------------------------------------------------------------------------
procedure TRadialGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dist: double;
color: TARGB;
pDst: PColor32;
begin
pDst := GetDstPixel(x1,y);
for i := x1 to x2 do
begin
dist := Hypot((y - fCenterPt.Y) *fScaleY, (i - fCenterPt.X) *fScaleX);
color.Color := fColors[fBoundsProc(Round(dist), fColorsCnt)];
pDst^ := BlendToAlpha(pDst^,
MulBytes(color.A, Ord(alpha^)) shl 24 or (color.Color and $FFFFFF));
inc(pDst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TSvgRadialGradientRenderer
//------------------------------------------------------------------------------
function TSvgRadialGradientRenderer.Initialize(targetImage: TImage32): Boolean;
begin
result := inherited Initialize(targetImage) and (fColorsCnt > 1);
if result then
fColors := MakeColorGradient(fGradientColors, fColorsCnt);
end;
//------------------------------------------------------------------------------
procedure TSvgRadialGradientRenderer.SetParameters(const ellipseRect: TRect;
const focus: TPoint; innerColor, outerColor: TColor32;
gradientFillStyle: TGradientFillStyle = gfsClamp);
var
w, h : integer;
begin
inherited SetParameters(innerColor, outerColor);
case gradientFillStyle of
gfsMirror: fBoundsProcD := MirrorD;
gfsRepeat: fBoundsProcD := RepeatD;
else fBoundsProcD := ClampD;
end;
fColorsCnt := 0;
if IsEmptyRect(ellipseRect) then Exit;
fCenterPt := RectD(ellipseRect).MidPoint;
RectWidthHeight(ellipseRect, w, h);
fA := w * 0.5;
fB := h * 0.5;
fFocusPt.X := focus.X - fCenterPt.X;
fFocusPt.Y := focus.Y - fCenterPt.Y;
fColorsCnt := Ceil(Hypot(fA*2, fB*2)) +1;
fAA := fA * fA;
fBB := fB * fB;
end;
//------------------------------------------------------------------------------
procedure TSvgRadialGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
q,m,c, qa,qb,qc,qs: double;
dist, dist2: double;
color: TARGB;
pDst: PColor32;
pt, ellipsePt: TPointD;
begin
//get the left-most pixel to render
pDst := GetDstPixel(x1,y);
pt.X := x1 - fCenterPt.X; pt.Y := y - fCenterPt.Y;
for i := x1 to x2 do
begin
//equation of ellipse = (x*x)/aa + (y*y)/bb = 1
//equation of line = y = mx + c;
if (pt.X = fFocusPt.X) then //vertical line
begin
//let x = pt.X, then y*y = b*b(1 - Sqr(pt.X)/aa)
q := Sqrt(fBB*(1 - Sqr(pt.X)/fAA));
ellipsePt.X := pt.X;
if pt.Y >= fFocusPt.Y then
ellipsePt.Y := q else
ellipsePt.Y := -q;
dist := abs(pt.Y - fFocusPt.Y);
dist2 := abs(ellipsePt.Y - fFocusPt.Y);
if dist2 = 0 then
q := 1 else
q := dist/ dist2;
end else
begin
//using simultaneous equations and substitution
//given y = mx + c
m := (pt.Y - fFocusPt.Y)/(pt.X - fFocusPt.X);
c := pt.Y - m * pt.X;
//given (x*x)/aa + (y*y)/bb = 1
//(x*x)/aa*bb + (y*y) = bb
//bb/aa *(x*x) + Sqr(m*x +c) = bb
//bb/aa *(x*x) + (m*m)*(x*x) + 2*m*x*c +c*c = b*b
//(bb/aa +(m*m)) *(x*x) + 2*m*c*(x) + (c*c) - bb = 0
//solving quadratic equation
qa := (fBB/fAA +(m*m));
qb := 2*m*c;
qc := (c*c) - fBB;
qs := (qb*qb) - 4*qa*qc;
if qs >= 0 then
begin
qs := Sqrt(qs);
if pt.X <= fFocusPt.X then
ellipsePt.X := (-qb -qs)/(2 * qa) else
ellipsePt.X := (-qb +qs)/(2 * qa);
ellipsePt.Y := m * ellipsePt.X + c;
dist := Hypot(pt.X - fFocusPt.X, pt.Y - fFocusPt.Y);
dist2 := Hypot(ellipsePt.X - fFocusPt.X, ellipsePt.Y - fFocusPt.Y);
if dist2 = 0 then
q := 1 else
q := dist/ dist2;
end else
q := 1; //shouldn't happen :)
end;
color.Color := fColors[fBoundsProcD(Abs(q), fColorsCnt)];
pDst^ := BlendToAlpha(pDst^,
MulBytes(color.A, Ord(alpha^)) shl 24 or (color.Color and $FFFFFF));
inc(pDst); pt.X := pt.X + 1; inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TEraseRenderer
//------------------------------------------------------------------------------
procedure TEraseRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dst: PARGB;
begin
dst := PARGB(GetDstPixel(x1,y));
for i := x1 to x2 do
begin
{$IFDEF PBYTE}
dst.A := MulBytes(dst.A, not alpha^);
{$ELSE}
dst.A := MulBytes(dst.A, not Ord(alpha^));
{$ENDIF}
inc(dst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TInverseRenderer
//------------------------------------------------------------------------------
procedure TInverseRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dst: PARGB;
c: TARGB;
begin
dst := PARGB(GetDstPixel(x1,y));
for i := x1 to x2 do
begin
c.Color := not dst.Color;
c.A := MulBytes(dst.A, Ord(alpha^));
dst.Color := BlendToAlpha(dst.Color, c.Color);
inc(dst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
procedure TBarycentricRenderer.SetParameters(const a, b, c: TPointD;
c1, c2, c3: TColor32);
begin
self.a := a;
self.c1.Color := c1;
self.c2.Color := c2;
self.c3.Color := c3;
v0.X := b.X - a.X;
v0.Y := b.Y - a.Y;
v1.X := c.X - a.X;
v1.Y := c.Y - a.Y;
d00 := (v0.X * v0.X + v0.Y * v0.Y);
d01 := (v0.X * v1.X + v0.Y * v1.Y);
d11 := (v1.X * v1.X + v1.Y * v1.Y);
invDenom := 1/(d00 * d11 - d01 * d01);
end;
//------------------------------------------------------------------------------
function TBarycentricRenderer.GetColor(const pt: TPointD): TColor32;
var
v2: TPointD;
d20, d21, v, w, u: Double;
res: TARGB absolute Result;
begin
Result := 0;
v2.X := pt.X - a.X;
v2.Y := pt.Y - a.Y;
d20 := (v2.X * v0.X + v2.Y * v0.Y);
d21 := (v2.X * v1.X + v2.Y * v1.Y);
v := (d11 * d20 - d01 * d21) * invDenom;
w := (d00 * d21 - d01 * d20) * invDenom;
u := 1.0 - v - w;
Res.A := ClampByte(c1.A * u + c2.A * v + c3.A * w);
Res.R := ClampByte(c1.R * u + c2.R * v + c3.R * w);
Res.G := ClampByte(c1.G * u + c2.G * v + c3.G * w);
Res.B := ClampByte(c1.B * u + c2.B * v + c3.B * w);
end;
//------------------------------------------------------------------------------
procedure TBarycentricRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
x: integer;
p: PARGB;
c: TARGB;
begin
p := PARGB(fImgBase);
inc(p, y * ImgWidth + x1);
for x := x1 to x2 do
begin
c.Color := GetColor(PointD(x, y));
c.A := c.A * Ord(alpha^) shr 8;
p.Color := BlendToAlpha(p.Color, c.Color);
inc(p); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// Draw functions
//------------------------------------------------------------------------------
procedure DrawPoint(img: TImage32;
const pt: TPointD; radius: double; color: TColor32);
var
path: TPathD;
begin
if radius <= 1 then
path := Rectangle(pt.X-radius, pt.Y-radius, pt.X+radius, pt.Y+radius) else
path := Ellipse(RectD(pt.X-radius, pt.Y-radius, pt.X+radius, pt.Y+radius));
DrawPolygon(img, path, frEvenOdd, color);
end;
//------------------------------------------------------------------------------
procedure DrawPoint(img: TImage32; const pt: TPointD;
radius: double; renderer: TCustomRenderer);
var
path: TPathD;
begin
path := Ellipse(RectD(pt.X -radius, pt.Y -radius, pt.X +radius, pt.Y +radius));
DrawPolygon(img, path, frEvenOdd, renderer);
end;
//------------------------------------------------------------------------------
procedure DrawPoint(img: TImage32; const points: TPathD;
radius: double; color: TColor32);
var
i: integer;
begin
for i := 0 to high(points) do
DrawPoint(img, points[i], radius, color);
end;
//------------------------------------------------------------------------------
procedure DrawPoint(img: TImage32; const paths: TPathsD;
radius: double; color: TColor32);
var
i: integer;
begin
for i := 0 to high(paths) do
DrawPoint(img, paths[i], radius, color);
end;
//------------------------------------------------------------------------------
procedure DrawLine(img: TImage32;
const pt1, pt2: TPointD; lineWidth: double; color: TColor32);
var
lines: TPathsD;
begin
setLength(lines, 1);
setLength(lines[0], 2);
lines[0][0] := pt1;
lines[0][1] := pt2;
DrawLine(img, lines, lineWidth, color, esRound);
end;
//------------------------------------------------------------------------------
procedure DrawLine(img: TImage32; const line: TPathD; lineWidth: double;
color: TColor32; endStyle: TEndStyle; joinStyle: TJoinStyle;
miterLimit: double);
var
lines: TPathsD;
begin
setLength(lines, 1);
lines[0] := line;
DrawLine(img, lines, lineWidth, color, endStyle, joinStyle, miterLimit);
end;
//------------------------------------------------------------------------------
procedure DrawLine(img: TImage32; const line: TPathD; lineWidth: double;
renderer: TCustomRenderer; endStyle: TEndStyle; joinStyle: TJoinStyle;
miterLimit: double);
var
lines: TPathsD;
begin
setLength(lines, 1);
lines[0] := line;
DrawLine(img, lines, lineWidth, renderer, endStyle, joinStyle, miterLimit);
end;
//------------------------------------------------------------------------------
procedure DrawInvertedLine(img: TImage32; const line: TPathD;
lineWidth: double; endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto);
var
lines: TPathsD;
begin
setLength(lines, 1);
lines[0] := line;
DrawInvertedLine(img, lines, lineWidth, endStyle, joinStyle);
end;
//------------------------------------------------------------------------------
procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle; miterLimit: double);
var
lines2: TPathsD;
cr: TCustomRenderer;
begin
if not assigned(lines) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
lines2 := Outline(lines, lineWidth, joinStyle, endStyle, miterLimit);
if img.AntiAliased then
cr := TColorRenderer.Create(color) else
cr := TAliasedColorRenderer.Create(color);
try
if cr.Initialize(img) then
begin
Rasterize(lines2, img.bounds, frNonZero, cr);
cr.NotifyChange;
end;
finally
cr.free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle;
miterLimit: double);
var
lines2: TPathsD;
begin
if (not assigned(lines)) or (not assigned(renderer)) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
lines2 := Outline(lines, lineWidth, joinStyle, endStyle, miterLimit);
if renderer.Initialize(img) then
begin
Rasterize(lines2, img.bounds, frNonZero, renderer);
renderer.NotifyChange;
end;
end;
//------------------------------------------------------------------------------
procedure DrawInvertedLine(img: TImage32;
const lines: TPathsD; lineWidth: double;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto);
var
lines2: TPathsD;
ir: TInverseRenderer;
begin
if not assigned(lines) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
lines2 := Outline(lines, lineWidth, joinStyle, endStyle, 2);
ir := TInverseRenderer.Create;
try
if ir.Initialize(img) then
begin
Rasterize(lines2, img.bounds, frNonZero, ir);
ir.NotifyChange;
end;
finally
ir.free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const line: TPathD;
dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
color: TColor32; endStyle: TEndStyle; joinStyle: TJoinStyle);
var
lines: TPathsD;
cr: TColorRenderer;
i: integer;
begin
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
if not assigned(line) then exit;
for i := 0 to High(dashPattern) do
if dashPattern[i] <= 0 then dashPattern[i] := 1;
lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset);
if Length(lines) = 0 then Exit;
case joinStyle of
jsSquare, jsMiter:
endStyle := esSquare;
jsRound:
endStyle := esRound;
else
endStyle := esButt;
end;
lines := Outline(lines, lineWidth, joinStyle, endStyle);
cr := TColorRenderer.Create(color);
try
if cr.Initialize(img) then
begin
Rasterize(lines, img.bounds, frNonZero, cr);
cr.NotifyChange;
end;
finally
cr.free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
color: TColor32; endStyle: TEndStyle; joinStyle: TJoinStyle);
var
i: integer;
begin
if not assigned(lines) then exit;
for i := 0 to high(lines) do
DrawDashedLine(img, lines[i],
dashPattern, patternOffset, lineWidth, color, endStyle, joinStyle);
end;
//------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const line: TPathD;
dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
renderer: TCustomRenderer; endStyle: TEndStyle; joinStyle: TJoinStyle);
var
i: integer;
lines: TPathsD;
begin
if (not assigned(line)) or (not assigned(renderer)) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
for i := 0 to High(dashPattern) do
if dashPattern[i] <= 0 then dashPattern[i] := 1;
lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset);
if Length(lines) = 0 then Exit;
lines := Outline(lines, lineWidth, joinStyle, endStyle);
if renderer.Initialize(img) then
begin
Rasterize(lines, img.bounds, frNonZero, renderer);
renderer.NotifyChange;
end;
end;
//------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
renderer: TCustomRenderer; endStyle: TEndStyle; joinStyle: TJoinStyle);
var
i: integer;
begin
if not assigned(lines) then exit;
for i := 0 to high(lines) do
DrawDashedLine(img, lines[i],
dashPattern, patternOffset, lineWidth, renderer, endStyle, joinStyle);
end;
//------------------------------------------------------------------------------
procedure DrawInvertedDashedLine(img: TImage32;
const line: TPathD; dashPattern: TArrayOfInteger;
patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto);
var
i: integer;
lines: TPathsD;
renderer: TInverseRenderer;
begin
if not assigned(line) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
for i := 0 to High(dashPattern) do
if dashPattern[i] <= 0 then dashPattern[i] := 1;
lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset);
if Length(lines) = 0 then Exit;
lines := Outline(lines, lineWidth, joinStyle, endStyle);
renderer := TInverseRenderer.Create;
try
if renderer.Initialize(img) then
begin
Rasterize(lines, img.bounds, frNonZero, renderer);
renderer.NotifyChange;
end;
finally
renderer.Free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawInvertedDashedLine(img: TImage32;
const lines: TPathsD; dashPattern: TArrayOfInteger;
patternOffset: PDouble; lineWidth: double;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto);
var
i: integer;
begin
if not assigned(lines) then exit;
for i := 0 to high(lines) do
DrawInvertedDashedLine(img, lines[i],
dashPattern, patternOffset, lineWidth, endStyle, joinStyle);
end;
//------------------------------------------------------------------------------
procedure DrawPolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; color: TColor32);
var
polygons: TPathsD;
begin
if not assigned(polygon) then exit;
setLength(polygons, 1);
polygons[0] := polygon;
DrawPolygon(img, polygons, fillRule, color);
end;
//------------------------------------------------------------------------------
procedure DrawPolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; renderer: TCustomRenderer);
var
polygons: TPathsD;
begin
if (not assigned(polygon)) or (not assigned(renderer)) then exit;
setLength(polygons, 1);
polygons[0] := polygon;
if renderer.Initialize(img) then
begin
Rasterize(polygons, img.Bounds, fillRule, renderer);
renderer.NotifyChange;
end;
end;
//------------------------------------------------------------------------------
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32);
var
cr: TCustomRenderer;
begin
if not assigned(polygons) then exit;
if img.AntiAliased then
cr := TColorRenderer.Create(color) else
cr := TAliasedColorRenderer.Create(color);
try
if cr.Initialize(img) then
begin
Rasterize(polygons, img.bounds, fillRule, cr);
cr.NotifyChange;
end;
finally
cr.free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; renderer: TCustomRenderer);
begin
if (not assigned(polygons)) or (not assigned(renderer)) then exit;
if renderer.Initialize(img) then
begin
Rasterize(polygons, img.bounds, fillRule, renderer);
renderer.NotifyChange;
end;
end;
//------------------------------------------------------------------------------
procedure DrawPolygon_ClearType(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32; backColor: TColor32);
var
w, h: integer;
tmpImg: TImage32;
rec: TRect;
tmpPolygons: TPathsD;
cr: TColorRenderer;
begin
if not assigned(polygons) then exit;
rec := GetBounds(polygons);
RectWidthHeight(rec, w, h);
tmpImg := TImage32.Create(w *3, h);
try
tmpPolygons := OffsetPath(polygons, -rec.Left, -rec.Top);
tmpPolygons := ScalePath(tmpPolygons, 3, 1);
cr := TColorRenderer.Create(clBlack32);
try
if cr.Initialize(tmpImg) then
Rasterize(tmpPolygons, tmpImg.bounds, fillRule, cr);
finally
cr.Free;
end;
ApplyClearType(tmpImg, color, backColor);
img.CopyBlend(tmpImg, tmpImg.Bounds, rec, BlendToAlpha);
finally
tmpImg.Free;
end;
end;
//------------------------------------------------------------------------------
procedure ErasePolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule);
var
polygons: TPathsD;
begin
if not assigned(polygon) then exit;
setLength(polygons, 1);
polygons[0] := polygon;
ErasePolygon(img, polygons, fillRule);
end;
//------------------------------------------------------------------------------
procedure ErasePolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule);
var
er: TEraseRenderer;
begin
er := TEraseRenderer.Create;
try
if er.Initialize(img) then
begin
Rasterize(polygons, img.bounds, fillRule, er);
er.NotifyChange;
end;
finally
er.Free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawBoolMask(img: TImage32; const mask: TArrayOfByte; color: TColor32);
var
i, len: integer;
pc: PColor32;
pb: PByte;
begin
len := Length(mask);
if (len = 0) or (len <> img.Width * img.Height) then Exit;
pc := img.PixelBase;
pb := @mask[0];
for i := 0 to len -1 do
begin
{$IFDEF PBYTE}
if pb^ > 0 then
{$ELSE}
if pb^ > #0 then
{$ENDIF}
pc^ := color else
pc^ := clNone32;
inc(pc); inc(pb);
end;
end;
//------------------------------------------------------------------------------
procedure DrawAlphaMask(img: TImage32; const mask: TArrayOfByte; color: TColor32);
var
i, len: integer;
pc: PColor32;
pb: PByte;
begin
len := Length(mask);
if (len = 0) or (len <> img.Width * img.Height) then Exit;
color := color and $FFFFFF; //strip alpha value
pc := img.PixelBase;
pb := @mask[0];
for i := 0 to len -1 do
begin
{$IFDEF PBYTE}
if pb^ > 0 then
pc^ := color or pb^ shl 24 else
pc^ := clNone32;
{$ELSE}
if pb^ > #0 then
pc^ := color or Ord(pb^) shl 24 else
pc^ := clNone32;
{$ENDIF}
inc(pc); inc(pb);
end;
end;
//------------------------------------------------------------------------------
end.
doublecmd-1.1.22/components/Image32/source/Img32.Extra.pas 0000644 0001750 0000144 00000271467 14743153644 022153 0 ustar alexx users unit Img32.Extra;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.3 *
* Date : 27 September 2022 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2021 *
* *
* Purpose : Miscellaneous routines for TImage32 that *
* : don't obviously belong in other modules. *
* *
* License : Use, modification & distribution is subject to *
* Boost Software License Ver 1 *
* http://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
uses
SysUtils, Classes, Math, Types,
Img32, Img32.Draw, Img32.Vector;
type
TButtonShape = (bsRound, bsSquare, bsDiamond);
TButtonAttribute = (baShadow, ba3D, baEraseBeneath);
TButtonAttributes = set of TButtonAttribute;
type
PPt = ^TPt;
TPt = record
pt : TPointD;
vec : TPointD;
len : double;
next : PPt;
prev : PPt;
end;
TFitCurveContainer = class
private
ppts : PPt;
solution : TPathD;
tolSqrd : double;
function Count(first, last: PPt): integer;
function AddPt(const pt: TPointD): PPt;
procedure Clear;
function ComputeLeftTangent(p: PPt): TPointD;
function ComputeRightTangent(p: PPt): TPointD;
function ComputeCenterTangent(p: PPt): TPointD;
function ChordLengthParameterize(
first: PPt; cnt: integer): TArrayOfDouble;
function GenerateBezier(first, last: PPt; cnt: integer;
const u: TArrayOfDouble; const firstTan, lastTan: TPointD): TPathD;
function Reparameterize(first: PPt; cnt: integer;
const u: TArrayOfDouble; const bezier: TPathD): TArrayOfDouble;
function NewtonRaphsonRootFind(const q: TPathD;
const pt: TPointD; u: double): double;
function ComputeMaxErrorSqrd(first, last: PPt;
const bezier: TPathD; const u: TArrayOfDouble;
out SplitPoint: PPt): double;
function FitCubic(first, last: PPt;
firstTan, lastTan: TPointD): Boolean;
procedure AppendSolution(const bezier: TPathD);
public
function FitCurve(const path: TPathD; closed: Boolean;
tolerance: double; minSegLength: double): TPathD;
end;
procedure DrawEdge(img: TImage32; const rec: TRect;
topLeftColor, bottomRightColor: TColor32; penWidth: double = 1.0); overload;
procedure DrawEdge(img: TImage32; const rec: TRectD;
topLeftColor, bottomRightColor: TColor32; penWidth: double = 1.0); overload;
procedure DrawEdge(img: TImage32; const path: TPathD;
topLeftColor, bottomRightColor: TColor32;
penWidth: double = 1.0; closePath: Boolean = true); overload;
//DrawShadowRect: is **much** faster than DrawShadow
procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double;
angle: double = angle45; color: TColor32 = $80000000);
procedure DrawShadow(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; depth: double; angleRads: double = angle45;
color: TColor32 = $80000000; cutoutInsideShadow: Boolean = false); overload;
procedure DrawShadow(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; depth: double; angleRads: double = angle45;
color: TColor32 = $80000000; cutoutInsideShadow: Boolean = false); overload;
procedure DrawGlow(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; color: TColor32; blurRadius: integer); overload;
procedure DrawGlow(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32; blurRadius: integer); overload;
procedure TileImage(img: TImage32; const rec: TRect; tile: TImage32); overload;
procedure TileImage(img: TImage32; const rec: TRect; tile: TImage32; const tileRec: TRect); overload;
//FloodFill: If no CompareFunc is provided, FloodFill will fill whereever
//adjoining pixels exactly match the starting pixel - Point(x,y).
procedure FloodFill(img: TImage32; x, y: Integer; newColor: TColor32;
tolerance: Byte = 0; compareFunc: TCompareFunctionEx = nil);
procedure FastGaussianBlur(img: TImage32;
const rec: TRect; stdDev: integer; repeats: integer); overload;
procedure FastGaussianBlur(img: TImage32;
const rec: TRect; stdDevX, stdDevY: integer; repeats: integer); overload;
procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer);
//Emboss: A smaller radius is sharper. Increasing depth increases contrast.
//Luminance changes grayscale balance (unless preserveColor = true)
procedure Emboss(img: TImage32; radius: Integer = 1; depth: Integer = 10;
luminance: Integer = 75; preserveColor: Boolean = false);
//Sharpen: Radius range is 1 - 10; amount range is 1 - 50.
//see https://en.wikipedia.org/wiki/Unsharp_masking
procedure Sharpen(img: TImage32; radius: Integer = 2; amount: Integer = 10);
//HatchBackground: Assumes the current image is semi-transparent.
procedure HatchBackground(img: TImage32; color1: TColor32 = clWhite32;
color2: TColor32= $FFE8E8E8; hatchSize: Integer = 10); overload;
procedure HatchBackground(img: TImage32; const rec: TRect;
color1: TColor32 = clWhite32; color2: TColor32= $FFE8E8E8;
hatchSize: Integer = 10); overload;
procedure GridBackground(img: TImage32; majorInterval, minorInterval: integer;
fillColor: TColor32 = clWhite32;
majColor: TColor32 = $30000000; minColor: TColor32 = $20000000);
procedure ReplaceColor(img: TImage32; oldColor, newColor: TColor32);
//EraseColor: Removes the specified color from the image, even from
//pixels that are a blend of colors including the specified color.
//see https://stackoverflow.com/questions/9280902/
procedure EraseColor(img: TImage32; color: TColor32);
//RedEyeRemove: Removes 'red eye' from flash photo images.
procedure RedEyeRemove(img: TImage32; const rect: TRect);
procedure PencilEffect(img: TImage32; intensity: integer = 0);
procedure TraceContours(img: TImage32; intensity: integer);
procedure EraseInsidePath(img: TImage32;
const path: TPathD; fillRule: TFillRule);
procedure EraseInsidePaths(img: TImage32;
const paths: TPathsD; fillRule: TFillRule);
procedure EraseOutsidePath(img: TImage32; const path: TPathD;
fillRule: TFillRule; const outsideBounds: TRect);
procedure EraseOutsidePaths(img: TImage32; const paths: TPathsD;
fillRule: TFillRule; const outsideBounds: TRect);
procedure Draw3D(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; height, blurRadius: double;
colorLt: TColor32 = $DDFFFFFF; colorDk: TColor32 = $80000000;
angleRads: double = angle225); overload;
procedure Draw3D(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; height, blurRadius: double;
colorLt: TColor32 = $DDFFFFFF; colorDk: TColor32 = $80000000;
angleRads: double = angle225); overload;
function RainbowColor(fraction: double): TColor32;
function GradientColor(color1, color2: TColor32; frac: single): TColor32;
function MakeDarker(color: TColor32; percent: cardinal): TColor32;
function MakeLighter(color: TColor32; percent: cardinal): TColor32;
function DrawButton(img: TImage32; const pt: TPointD;
size: double; color: TColor32 = clNone32;
buttonShape: TButtonShape = bsRound;
buttonAttributes: TButtonAttributes = [baShadow, ba3D, baEraseBeneath]): TPathD;
//Vectorize: convert an image into polygon vectors
function Vectorize(img: TImage32; compareColor: TColor32;
compareFunc: TCompareFunction; colorTolerance: Integer;
roundingTolerance: integer = 2): TPathsD;
function VectorizeMask(const mask: TArrayOfByte; maskWidth: integer): TPathsD;
// RamerDouglasPeucker: simplifies paths, recursively removing vertices where
// they deviate no more than 'epsilon' from their adjacent vertices.
function RamerDouglasPeucker(const path: TPathD;
epsilon: double): TPathD; overload;
function RamerDouglasPeucker(const paths: TPathsD;
epsilon: double): TPathsD; overload;
// SmoothToCubicBezier - produces a series of cubic bezier control points.
// This function is very useful in the following combination:
// RamerDouglasPeucker(), SmoothToCubicBezier(), FlattenCBezier().
function SmoothToCubicBezier(const path: TPathD;
pathIsClosed: Boolean; maxOffset: integer = 0): TPathD;
//InterpolatePoints: smooths a simple line chart.
//Points should be left to right and equidistant along the X axis
function InterpolatePoints(const points: TPathD; tension: integer = 0): TPathD;
function GetFloodFillMask(imgIn, imgMaskOut: TImage32; x, y: Integer;
tolerance: Byte; compareFunc: TCompareFunctionEx): Boolean;
procedure SymmetricCropTransparent(img: TImage32);
//3 additional blend functions (see TImage32.CopyBlend)
function BlendAverage(bgColor, fgColor: TColor32): TColor32;
function BlendLinearBurn(bgColor, fgColor: TColor32): TColor32;
function BlendColorDodge(bgColor, fgColor: TColor32): TColor32;
//CurveFit: this function is based on -
//"An Algorithm for Automatically Fitting Digitized Curves"
//by Philip J. Schneider in "Graphics Gems", Academic Press, 1990
//Smooths out many very closely positioned points
//tolerance range: 1..10 where 10 == max tolerance.
function CurveFit(const path: TPathD; closed: Boolean;
tolerance: double; minSegLength: double = 2): TPathD; overload;
function CurveFit(const paths: TPathsD; closed: Boolean;
tolerance: double; minSegLength: double = 2): TPathsD; overload;
implementation
uses
{$IFNDEF MSWINDOWS}
{$IFNDEF FPC}
Img32.FMX,
{$ENDIF}
{$ENDIF}
Img32.Transform;
const
FloodFillDefaultRGBTolerance: byte = 64;
MaxBlur = 100;
type
PColor32Array = ^TColor32Array;
TColor32Array = array [0.. maxint div SizeOf(TColor32) -1] of TColor32;
PWeightedColorArray = ^TWeightedColorArray;
TWeightedColorArray = array [0.. $FFFFFF] of TWeightedColor;
//------------------------------------------------------------------------------
// Miscellaneous functions
//------------------------------------------------------------------------------
function GetSymmetricCropTransparentRect(img: TImage32): TRect;
var
w,h, x,y, x1,y1: Integer;
p1,p2: PARGB;
opaquePxlFound: Boolean;
begin
Result := img.Bounds;
w := img.Width;
y1 := 0;
opaquePxlFound := false;
for y := 0 to (img.Height div 2) -1 do
begin
p1 := PARGB(img.PixelRow[y]);
p2 := PARGB(img.PixelRow[img.Height - y -1]);
for x := 0 to w -1 do
begin
if (p1.A > 0) or (p2.A > 0) then
begin
y1 := y;
opaquePxlFound := true;
break;
end;
inc(p1); inc(p2);
end;
if opaquePxlFound then break;
end;
// probably safeset not to resize empty images
if not opaquePxlFound then Exit;
if y1 > 0 then
begin
inc(Result.Top, y1);
dec(Result.Bottom, y1);
end;
x1 := 0;
h := RectHeight(Result);
opaquePxlFound := false;
for x := 0 to (w div 2) -1 do
begin
p1 := PARGB(@img.Pixels[Result.Top * w + x]);
p2 := PARGB(@img.Pixels[Result.Top * w + (w -1) - x]);
for y := 0 to h -1 do
begin
if (p1.A > 0) or (p2.A > 0) then
begin
x1 := x;
opaquePxlFound := true;
break;
end;
inc(p1, w); inc(p2, w);
end;
if opaquePxlFound then break;
end;
if not opaquePxlFound then Exit;
inc(Result.Left, x1);
dec(Result.Right, x1);
end;
//------------------------------------------------------------------------------
//SymmetricCropTransparent: after cropping, the image's midpoint
//will be the same pixel as before cropping. (Important for rotating.)
procedure SymmetricCropTransparent(img: TImage32);
var
rec: TRect;
begin
rec := GetSymmetricCropTransparentRect(img);
if (rec.Top > 0) or (rec.Left > 0) then img.Crop(rec);
end;
//------------------------------------------------------------------------------
procedure DrawEdge(img: TImage32; const rec: TRect;
topLeftColor, bottomRightColor: TColor32; penWidth: double = 1.0);
begin
DrawEdge(img, RectD(rec), topLeftColor, bottomRightColor, penWidth);
end;
//------------------------------------------------------------------------------
procedure DrawEdge(img: TImage32; const rec: TRectD;
topLeftColor, bottomRightColor: TColor32; penWidth: double = 1.0);
var
p: TPathD;
c: TColor32;
begin
if penWidth = 0 then Exit
else if penWidth < 0 then
begin
c := topLeftColor;
topLeftColor := bottomRightColor;
bottomRightColor := c;
penWidth := -penWidth;
end;
if topLeftColor <> bottomRightColor then
begin
with rec do
begin
p := Img32.Vector.MakePath([left, bottom, left, top, right, top]);
DrawLine(img, p, penWidth, topLeftColor, esButt);
p := Img32.Vector.MakePath([right, top, right, bottom, left, bottom]);
DrawLine(img, p, penWidth, bottomRightColor, esButt);
end;
end else
DrawLine(img, Rectangle(rec), penWidth, topLeftColor, esPolygon);
end;
//------------------------------------------------------------------------------
procedure DrawEdge(img: TImage32; const path: TPathD;
topLeftColor, bottomRightColor: TColor32;
penWidth: double = 1.0; closePath: Boolean = true);
var
i, highI, deg: integer;
frac: double;
c: TColor32;
p: TPathD;
const
RadToDeg = 180/PI;
begin
if penWidth = 0 then Exit
else if penWidth < 0 then
begin
c := topLeftColor;
topLeftColor := bottomRightColor;
bottomRightColor := c;
penWidth := -penWidth;
end;
highI := high(path);
if highI < 2 then Exit;
p := path;
if closePath and not PointsNearEqual(p[0], p[highI], 0.01) then
begin
AppendPath(p, p[0]);
inc(highI);
end;
for i := 1 to highI do
begin
deg := Round(GetAngle(p[i-1], p[i]) * RadToDeg);
case deg of
-180..-136: frac := (-deg-135)/45;
-135..0 : frac := 0;
1..44 : frac := deg/45;
else frac := 1;
end;
c := GradientColor(topLeftColor, bottomRightColor, frac);
DrawLine(img, p[i-1], p[i], penWidth, c);
end;
end;
//------------------------------------------------------------------------------
procedure FillColorHorz(img: TImage32; x, endX, y: integer; color: TColor32);
var
i,dx: integer;
p: PColor32;
begin
if (x < 0) or (x >= img.Width) then Exit;
if (y < 0) or (y >= img.Height) then Exit;
p := img.PixelRow[y]; inc(p, x);
if endX >= img.Width then endX := img.Width -1
else if endX < 0 then endX := 0;
if endX < x then dx := -1 else dx := 1;
for i := 0 to Abs(x-endX) do
begin
p^ := color;
inc(p, dx);
end;
end;
//------------------------------------------------------------------------------
procedure FillColorVert(img: TImage32; x, y, endY: integer; color: TColor32);
var
i, dy: integer;
p: PColor32;
begin
if (x < 0) or (x >= img.Width) then Exit;
if (y < 0) or (y >= img.Height) then Exit;
p := img.PixelRow[y]; inc(p, x);
if endY >= img.Height then
endY := img.Height -1 else if endY < 0 then endY := 0;
dy := img.Width;
if endY < y then dy := -dy;
for i := 0 to Abs(y - endY) do
begin
p^ := color;
inc(p, dy);
end;
end;
//------------------------------------------------------------------------------
procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double;
angle: double = angle45; color: TColor32 = $80000000);
var
i,j, sX,sY: integer;
l,t,r,b: integer;
tmpImg: TImage32;
tmpRec: TRect;
xx,yy: double;
ss: TPointD;
c: TColor32;
begin
GetSinCos(angle, yy, xx);
ss.X := depth * xx;
ss.Y := depth * yy;
sX := Abs(Round(ss.X));
sY := Abs(Round(ss.Y));
if rec.Left + ss.X < 0 then ss.X := -rec.Left
else if rec.Right + ss.X > img.Width then ss.X := img.Width - rec.Right -1;
if rec.Top + ss.Y < 0 then ss.Y := -rec.Top
else if rec.Bottom + ss.Y > img.Height then ss.Y := img.Height -rec.Bottom -1;
tmpImg := TImage32.Create(sX*3 +1, sY*3 +1);
try
i := sX div 2; j := sY div 2;
DrawPolygon(tmpImg, Rectangle(i,j,i+sX*2,j+sY*2), frNonZero, color);
FastGaussianBlur(tmpImg, tmpImg.Bounds, Round(sX/4),Round(sY/4), 1);
// t-l corner
if (ss.X < 0) or (ss.Y < 0) then
begin
tmpRec := Rect(0, 0, sX, sY);
l := rec.Left; t := rec.Top;
if ss.X < 0 then dec(l, sX);
if ss.Y < 0 then dec(t, sY);
img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY));
end;
// t-r corner
if (ss.X > 0) or (ss.Y < 0) then
begin
tmpRec := Rect(sX*2+1, 0, sX*3+1, sY);
l := rec.Right; t := rec.Top;
if ss.X < 0 then dec(l, sX);
if ss.Y < 0 then dec(t, sY);
img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY));
end;
// b-l corner
if (ss.X < 0) or (ss.Y > 0) then
begin
tmpRec := Rect(0, sY*2+1, sX, sY*3+1);
l := rec.Left; t := rec.Bottom;
if ss.X < 0 then dec(l, sX);
if ss.Y < 0 then dec(t, sY);
img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY));
end;
// b-r corner
if (ss.X > 0) or (ss.Y > 0) then
begin
tmpRec := Rect(sX*2+1, sY*2+1, sX*3+1, sY*3+1);
l := rec.Right; t := rec.Bottom;
if ss.X < 0 then dec(l, sX);
if ss.Y < 0 then dec(t, sY);
img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY));
end;
// l-edge
if (ss.X < 0) then
begin
l := rec.Left; t := rec.Top+sY; b := rec.Bottom-1;
if ss.Y < 0 then begin dec(t, sY); dec(b,sY); end;
for i := 1 to sX do
begin
c := tmpImg.Pixel[sX-i, sY+1];
FillColorVert(img, l-i, t, b, c);
end;
end;
// t-edge
if (ss.Y < 0) then
begin
l := rec.Left+sX; r := rec.Right-1; t := rec.Top;
if ss.X < 0 then begin dec(l, sX); dec(r,sX); end;
for i := 1 to sY do
begin
c := tmpImg.Pixel[sX+1, sY-i];
FillColorHorz(img, l, r, t-i, c);
end;
end;
// r-edge
if (ss.X > 0) then
begin
r := rec.Right-1; t := rec.Top+sY; b := rec.Bottom-1;
if ss.Y < 0 then begin dec(t, sY); dec(b,sY); end;
for i := 1 to sX do
begin
c := tmpImg.Pixel[sX*2+i, sY+1];
FillColorVert(img, r+i, t, b, c);
end;
end;
// b-edge
if (ss.Y > 0) then
begin
l := rec.Left+sX; r := rec.Right-1; b := rec.Bottom-1;
if ss.X < 0 then begin dec(l, sX); dec(r,sX); end;
for i := 1 to sY do
begin
c := tmpImg.Pixel[sX+1, sY*2+i];
FillColorHorz(img, l, r, b+i, c);
end;
end;
finally
tmpImg.Free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawShadow(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; depth: double; angleRads: double;
color: TColor32; cutoutInsideShadow: Boolean);
var
polygons: TPathsD;
begin
setlength(polygons, 1);
polygons[0] := polygon;
DrawShadow(img, polygons, fillRule, depth,
angleRads, color, cutoutInsideShadow);
end;
//------------------------------------------------------------------------------
procedure DrawShadow(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; depth: double; angleRads: double;
color: TColor32; cutoutInsideShadow: Boolean);
var
x, y: double;
blurSize, w,h: integer;
rec: TRect;
polys, shadowPolys: TPathsD;
shadowImg: TImage32;
begin
rec := GetBounds(polygons);
if IsEmptyRect(rec) or (depth < 1) then Exit;
if not ClockwiseRotationIsAnglePositive then angleRads := -angleRads;
NormalizeAngle(angleRads);
GetSinCos(angleRads, y, x);
depth := depth * 0.5;
x := depth * x;
y := depth * y;
blurSize := Max(1,Round(depth / 2));
Img32.Vector.InflateRect(rec, Ceil(depth*2), Ceil(depth*2));
polys := OffsetPath(polygons, -rec.Left, -rec.Top);
shadowPolys := OffsetPath(polys, x, y);
RectWidthHeight(rec, w, h);
shadowImg := TImage32.Create(w, h);
try
DrawPolygon(shadowImg, shadowPolys, fillRule, color);
FastGaussianBlur(shadowImg, shadowImg.Bounds, blurSize, 1);
if cutoutInsideShadow then EraseInsidePaths(shadowImg, polys, fillRule);
img.CopyBlend(shadowImg, shadowImg.Bounds, rec, BlendToAlpha);
finally
shadowImg.Free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawGlow(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; color: TColor32; blurRadius: integer);
var
polygons: TPathsD;
begin
setlength(polygons, 1);
polygons[0] := polygon;
DrawGlow(img, polygons, fillRule, color, blurRadius);
end;
//------------------------------------------------------------------------------
procedure DrawGlow(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32; blurRadius: integer);
var
w,h: integer;
rec: TRect;
glowPolys: TPathsD;
glowImg: TImage32;
begin
rec := GetBounds(polygons);
glowPolys := OffsetPath(polygons,
blurRadius -rec.Left +1, blurRadius -rec.Top +1);
Img32.Vector.InflateRect(rec, blurRadius +1, blurRadius +1);
RectWidthHeight(rec, w, h);
glowImg := TImage32.Create(w, h);
try
DrawPolygon(glowImg, glowPolys, fillRule, color);
FastGaussianBlur(glowImg, glowImg.Bounds, blurRadius, 2);
glowImg.ScaleAlpha(4);
img.CopyBlend(glowImg, glowImg.Bounds, rec, BlendToAlpha);
finally
glowImg.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TileImage(img: TImage32; const rec: TRect; tile: TImage32);
begin
TileImage(img, rec, tile, tile.Bounds);
end;
//------------------------------------------------------------------------------
procedure TileImage(img: TImage32;
const rec: TRect; tile: TImage32; const tileRec: TRect);
var
i, dstW, dstH, srcW, srcH, cnt: integer;
dstRec, srcRec: TRect;
begin
if tile.IsEmpty or IsEmptyRect(tileRec) then Exit;
RectWidthHeight(rec, dstW,dstH);
RectWidthHeight(tileRec, srcW, srcH);
cnt := Ceil(dstW / srcW);
dstRec := Img32.Vector.Rect(rec.Left, rec.Top,
rec.Left + srcW, rec.Top + srcH);
for i := 1 to cnt do
begin
img.Copy(tile, tileRec, dstRec);
Types.OffsetRect(dstRec, srcW, 0);
end;
cnt := Ceil(dstH / srcH) -1;
srcRec := Img32.Vector.Rect(rec.Left, rec.Top,
rec.Right, rec.Top + srcH);
dstRec := srcRec;
for i := 1 to cnt do
begin
Types.OffsetRect(dstRec, 0, srcH);
img.Copy(img, srcRec, dstRec);
end;
end;
//------------------------------------------------------------------------------
procedure Sharpen(img: TImage32; radius: Integer; amount: Integer);
var
i: Integer;
amt: double;
weightAmount: array [-255 .. 255] of Integer;
bmpBlur: TImage32;
pColor, pBlur: PARGB;
begin
if radius = 0 then Exit;
amt := ClampRange(amount/10, 0.1, 5);
radius := ClampRange(radius, 1, 10);
for i := -255 to 255 do
weightAmount[i] := Round(amt * i);
bmpBlur := TImage32.Create(img); // clone self
try
pColor := PARGB(img.pixelBase);
FastGaussianBlur(bmpBlur, bmpBlur.Bounds, radius, 2);
pBlur := PARGB(bmpBlur.pixelBase);
for i := 1 to img.Width * img.Height do
begin
if (pColor.A > 0) then
begin
pColor.R := ClampByte(pColor.R + weightAmount[pColor.R - pBlur.R]);
pColor.G := ClampByte(pColor.G + weightAmount[pColor.G - pBlur.G]);
pColor.B := ClampByte(pColor.B + weightAmount[pColor.B - pBlur.B]);
end;
Inc(pColor); Inc(pBlur);
end;
finally
bmpBlur.Free;
end;
end;
//------------------------------------------------------------------------------
procedure HatchBackground(img: TImage32; const rec: TRect;
color1: TColor32 = clWhite32; color2: TColor32= $FFE8E8E8;
hatchSize: Integer = 10); overload;
var
i,j: Integer;
pc: PColor32;
colors: array[boolean] of TColor32;
hatch: Boolean;
begin
colors[false] := color1;
colors[true] := color2;
img.BeginUpdate;
try
for i := rec.Top to rec.Bottom -1 do
begin
pc := img.PixelRow[i];
inc(pc, rec.Left);
hatch := Odd(i div hatchSize);
for j := rec.Left to rec.Right -1 do
begin
if (j + 1) mod hatchSize = 0 then hatch := not hatch;
pc^ := BlendToOpaque(pc^, colors[hatch]);
inc(pc);
end;
end;
finally
img.EndUpdate;
end;
end;
//------------------------------------------------------------------------------
procedure HatchBackground(img: TImage32;
color1: TColor32; color2: TColor32; hatchSize: Integer);
begin
HatchBackground(img, img.Bounds, color1, color2, hatchSize);
end;
//------------------------------------------------------------------------------
procedure GridBackground(img: TImage32; majorInterval, minorInterval: integer;
fillColor: TColor32; majColor: TColor32; minColor: TColor32);
var
i, x,y, w,h: integer;
path: TPathD;
begin
img.Clear(fillColor);
w := img.Width; h := img.Height;
SetLength(path, 2);
if minorInterval > 0 then
begin
x := minorInterval;
path[0] := PointD(x, 0); path[1] := PointD(x, h);;
for i := 1 to (w div minorInterval) do
begin
Img32.Draw.DrawLine(img, path, 1, minColor, esSquare);
path[0].X := path[0].X + minorInterval;
path[1].X := path[1].X + minorInterval;
end;
y := minorInterval;
path[0] := PointD(0, y); path[1] := PointD(w, y);
for i := 1 to (h div minorInterval) do
begin
Img32.Draw.DrawLine(img, path, 1, minColor, esSquare);
path[0].Y := path[0].Y + minorInterval;
path[1].Y := path[1].Y + minorInterval;
end;
end;
if majorInterval > minorInterval then
begin
x := majorInterval;
path[0] := PointD(x, 0); path[1] := PointD(x, h);;
for i := 1 to (w div majorInterval) do
begin
Img32.Draw.DrawLine(img, path, 1, majColor, esSquare);
path[0].X := path[0].X + majorInterval;
path[1].X := path[1].X + majorInterval;
end;
y := majorInterval;
path[0] := PointD(0, y); path[1] := PointD(w, y);
for i := 1 to (h div majorInterval) do
begin
Img32.Draw.DrawLine(img, path, 1, majColor, esSquare);
path[0].Y := path[0].Y + majorInterval;
path[1].Y := path[1].Y + majorInterval;
end;
end;
end;
//------------------------------------------------------------------------------
function ColorDifference(color1, color2: TColor32): cardinal;
{$IFDEF INLINE} inline; {$ENDIF}
var
c1: TARGB absolute color1;
c2: TARGB absolute color2;
begin
result := Abs(c1.R - c2.R) + Abs(c1.G - c2.G) + Abs(c1.B - c2.B);
result := (result * 341) shr 10; // divide by 3
end;
//------------------------------------------------------------------------------
procedure ReplaceColor(img: TImage32; oldColor, newColor: TColor32);
var
color: PColor32;
i: Integer;
begin
color := img.PixelBase;
for i := 0 to img.Width * img.Height -1 do
begin
if color^ = oldColor then color^ := newColor;
inc(color);
end;
end;
//------------------------------------------------------------------------------
procedure EraseColor(img: TImage32; color: TColor32);
var
fg: TARGB absolute color;
bg: PARGB;
i: Integer;
Q: byte;
begin
if fg.A = 0 then Exit;
bg := PARGB(img.PixelBase);
for i := 0 to img.Width * img.Height -1 do
begin
if bg.A > 0 then
begin
if (bg.R > fg.R) then Q := DivTable[bg.R - fg.R, not fg.R]
else if (bg.R < fg.R) then Q := DivTable[fg.R - bg.R, fg.R]
else Q := 0;
if (bg.G > fg.G) then Q := Max(Q, DivTable[bg.G - fg.G, not fg.G])
else if (bg.G < fg.G) then Q := Max(Q, DivTable[fg.G - bg.G, fg.G]);
if (bg.B > fg.B) then Q := Max(Q, DivTable[bg.B - fg.B, not fg.B])
else if (bg.B < fg.B) then Q := Max(Q, DivTable[fg.B - bg.B, fg.B]);
if (Q > 0) then
begin
bg.A := MulTable[bg.A, Q];
bg.R := DivTable[bg.R - MulTable[fg.R, not Q], Q];
bg.G := DivTable[bg.G - MulTable[fg.G, not Q], Q];
bg.B := DivTable[bg.B - MulTable[fg.B, not Q], Q];
end else
bg.Color := clNone32;
end;
inc(bg);
end;
end;
//------------------------------------------------------------------------------
procedure RedEyeRemove(img: TImage32; const rect: TRect);
var
k: integer;
cutout, mask: TImage32;
path: TPathD;
cutoutRec, rect3: TRect;
radGrad: TRadialGradientRenderer;
begin
k := RectWidth(rect) * RectHeight(rect);
if k < 120 then k := 2
else if k < 230 then k := 3
else k := 4;
cutoutRec := rect;
Img32.Vector.InflateRect(cutoutRec, k, k);
cutout := TImage32.Create(img, cutoutRec);
mask := TImage32.Create(cutout.Width, cutout.Height);
radGrad := TRadialGradientRenderer.Create;
try
// fill behind the cutout with black also
// blurring the fill to soften its edges
rect3 := cutout.Bounds;
Img32.Vector.InflateRect(rect3, -k, -k);
path := Ellipse(rect3);
DrawPolygon(mask, path, frNonZero, clBlack32);
// given the very small area and small radius of the blur, the
// speed improvement of BoxBlur over GaussianBlur is inconsequential.
GaussianBlur(mask, mask.Bounds, k);
img.CopyBlend(mask, mask.Bounds, cutoutRec, BlendToOpaque);
// gradient fill to clNone32 a mask to soften cutout's edges
path := Ellipse(cutoutRec);
radGrad.SetParameters(rect3, clBlack32, clNone32);
DrawPolygon(mask, path, frNonZero, radGrad);
cutout.CopyBlend(mask, mask.Bounds, cutout.Bounds, BlendMask);
// now remove red from the cutout
EraseColor(cutout, clRed32);
// finally replace the cutout ...
img.CopyBlend(cutout, cutout.Bounds, cutoutRec, BlendToOpaque);
finally
mask.Free;
cutout.Free;
radGrad.Free;
end;
end;
//------------------------------------------------------------------------------
procedure EraseInsidePath(img: TImage32; const path: TPathD; fillRule: TFillRule);
begin
if assigned(path) then
ErasePolygon(img, path, fillRule);
end;
//------------------------------------------------------------------------------
procedure EraseInsidePaths(img: TImage32; const paths: TPathsD; fillRule: TFillRule);
begin
if assigned(paths) then
ErasePolygon(img, paths, fillRule);
end;
//------------------------------------------------------------------------------
procedure EraseOutsidePath(img: TImage32; const path: TPathD;
fillRule: TFillRule; const outsideBounds: TRect);
var
mask: TImage32;
p: TPathD;
w,h: integer;
begin
if not assigned(path) then Exit;
RectWidthHeight(outsideBounds, w,h);
mask := TImage32.Create(w, h);
try
p := OffsetPath(path, -outsideBounds.Left, -outsideBounds.top);
DrawPolygon(mask, p, fillRule, clBlack32);
img.CopyBlend(mask, mask.Bounds, outsideBounds, BlendMask);
finally
mask.Free;
end;
end;
//------------------------------------------------------------------------------
procedure EraseOutsidePaths(img: TImage32; const paths: TPathsD;
fillRule: TFillRule; const outsideBounds: TRect);
var
mask: TImage32;
pp: TPathsD;
w,h: integer;
begin
if not assigned(paths) then Exit;
RectWidthHeight(outsideBounds, w,h);
mask := TImage32.Create(w, h);
try
pp := OffsetPath(paths, -outsideBounds.Left, -outsideBounds.top);
DrawPolygon(mask, pp, fillRule, clBlack32);
img.CopyBlend(mask, mask.Bounds, outsideBounds, BlendMask);
finally
mask.Free;
end;
end;
//------------------------------------------------------------------------------
procedure Draw3D(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; height, blurRadius: double;
colorLt: TColor32; colorDk: TColor32; angleRads: double);
var
polygons: TPathsD;
begin
setLength(polygons, 1);
polygons[0] := polygon;
Draw3D(img, polygons, fillRule, height, blurRadius, colorLt, colorDk, angleRads);
end;
//------------------------------------------------------------------------------
procedure Draw3D(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; height, blurRadius: double;
colorLt: TColor32; colorDk: TColor32; angleRads: double);
var
tmp: TImage32;
rec: TRect;
paths, paths2: TPathsD;
w,h: integer;
x,y: double;
begin
rec := GetBounds(polygons);
if IsEmptyRect(rec) then Exit;
if not ClockwiseRotationIsAnglePositive then angleRads := -angleRads;
GetSinCos(angleRads, y, x);
paths := OffsetPath(polygons, -rec.Left, -rec.Top);
RectWidthHeight(rec, w, h);
tmp := TImage32.Create(w, h);
try
if GetAlpha(colorLt) > 0 then
begin
tmp.Clear(colorLt);
paths2 := OffsetPath(paths, -height*x, -height*y);
EraseInsidePaths(tmp, paths2, fillRule);
FastGaussianBlur(tmp, tmp.Bounds, Round(blurRadius), 0);
EraseOutsidePaths(tmp, paths, fillRule, tmp.Bounds);
img.CopyBlend(tmp, tmp.Bounds, rec, BlendToAlpha);
end;
if GetAlpha(colorDk) > 0 then
begin
tmp.Clear(colorDk);
paths2 := OffsetPath(paths, height*x, height*y);
EraseInsidePaths(tmp, paths2, fillRule);
FastGaussianBlur(tmp, tmp.Bounds, Round(blurRadius), 0);
EraseOutsidePaths(tmp, paths, fillRule, tmp.Bounds);
img.CopyBlend(tmp, tmp.Bounds, rec, BlendToAlpha);
end;
finally
tmp.Free;
end;
end;
//------------------------------------------------------------------------------
function RainbowColor(fraction: double): TColor32;
var
hsl: THsl;
begin
if (fraction > 0) and (fraction < 1) then
begin
hsl.hue := Round(fraction * 255);
hsl.sat := 255;
hsl.lum := 255;
hsl.alpha := 255;
Result := HslToRgb(hsl);
end else
result := clRed32
end;
//------------------------------------------------------------------------------
function GradientColor(color1, color2: TColor32; frac: single): TColor32;
var
hsl1, hsl2: THsl;
begin
if (frac <= 0) then result := color1
else if (frac >= 1) then result := color2
else
begin
hsl1 := RgbToHsl(color1); hsl2 := RgbToHsl(color2);
hsl1.hue := ClampByte(hsl1.hue*(1-frac) + hsl2.hue*frac);
hsl1.sat := ClampByte(hsl1.sat*(1-frac) + hsl2.sat*frac);
hsl1.lum := ClampByte(hsl1.lum*(1-frac) + hsl2.lum*frac);
hsl1.alpha := ClampByte(hsl1.alpha*(1-frac) + hsl2.alpha*frac);
Result := HslToRgb(hsl1);
end;
end;
//------------------------------------------------------------------------------
function MakeDarker(color: TColor32; percent: cardinal): TColor32;
var
hsl: THsl;
begin
hsl := RgbToHsl(color);
hsl.lum := ClampByte(hsl.lum - (percent/100 * hsl.lum));
Result := HslToRgb(hsl);
end;
//------------------------------------------------------------------------------
function MakeLighter(color: TColor32; percent: cardinal): TColor32;
var
hsl: THsl;
begin
hsl := RgbToHsl(color);
hsl.lum := ClampByte(hsl.lum + percent/100 * (255 - hsl.lum));
Result := HslToRgb(hsl);
end;
//------------------------------------------------------------------------------
function DrawButton(img: TImage32; const pt: TPointD;
size: double; color: TColor32; buttonShape: TButtonShape;
buttonAttributes: TButtonAttributes): TPathD;
var
i: integer;
radius: double;
rec: TRectD;
lightSize, lightAngle: double;
begin
if (size < 5) then Exit;
radius := size * 0.5;
lightSize := radius * 0.25;
rec := RectD(pt.X -radius, pt.Y -radius, pt.X +radius, pt.Y +radius);
if baEraseBeneath in buttonAttributes then
img.Clear(Rect(rec));
case buttonShape of
bsDiamond:
begin
SetLength(Result, 4);
for i := 0 to 3 do Result[i] := pt;
Result[0].X := Result[0].X -radius;
Result[1].Y := Result[1].Y -radius;
Result[2].X := Result[2].X +radius;
Result[3].Y := Result[3].Y +radius;
end;
bsSquare:
begin
Img32.Vector.InflateRect(rec, -1,-1);
Result := Rectangle(rec);
end;
else
Result := Ellipse(rec);
end;
lightAngle := angle225;
img.BeginUpdate;
try
// nb: only need to cutout the inside shadow if
// the pending color fill is semi-transparent
if baShadow in buttonAttributes then
DrawShadow(img, Result, frNonZero, lightSize *2,
(lightAngle + angle180), $AA000000, GetAlpha(color) < $FE);
if GetAlpha(color) > 2 then
DrawPolygon(img, Result, frNonZero, color);
if ba3D in buttonAttributes then
Draw3D(img, Result, frNonZero, lightSize*2,
Ceil(lightSize), $CCFFFFFF, $AA000000, lightAngle);
DrawLine(img, Result, dpiAware1, clBlack32, esPolygon);
finally
img.EndUpdate;
end;
end;
//------------------------------------------------------------------------------
function AlphaAverage(color1, color2: TColor32): cardinal;
{$IFDEF INLINE} inline; {$ENDIF}
var
c1: TARGB absolute color1;
c2: TARGB absolute color2;
begin
result := (c1.A + c2.A) shr 1;
end;
//------------------------------------------------------------------------------
function BlendAverage(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
begin
res.A := (fg.A + bg.A) shr 1;
res.R := (fg.R + bg.R) shr 1;
res.G := (fg.G + bg.G) shr 1;
res.B := (fg.B + bg.B) shr 1;
end;
//------------------------------------------------------------------------------
function BlendLinearBurn(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
begin
res.A := 255;
res.R := Max(0, bg.R + fg.R - 255);
res.G := Max(0, bg.G + fg.G - 255);
res.B := Max(0, bg.B + fg.B - 255);
end;
//------------------------------------------------------------------------------
function BlendColorDodge(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
begin
res.A := 255;
res.R := DivTable[bg.R, not fg.R];
res.G := DivTable[bg.G, not fg.G];
res.B := DivTable[bg.B, not fg.B];
end;
//------------------------------------------------------------------------------
procedure PencilEffect(img: TImage32; intensity: integer);
var
img2: TImage32;
begin
if img.IsEmpty then Exit;
intensity := max(1, min(10, intensity));
img.Grayscale;
img2 := TImage32.Create(img);
try
img2.InvertColors;
FastGaussianBlur(img2, img2.Bounds, intensity, 2);
img.CopyBlend(img2, img2.Bounds, img.Bounds, BlendColorDodge);
finally
img2.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TraceContours(img: TImage32; intensity: integer);
var
i,j, w,h: integer;
tmp, tmp2: TArrayOfColor32;
s, s2: PColor32;
d: PARGB;
begin
w := img.Width; h := img.Height;
if w * h = 0 then Exit;
SetLength(tmp, w * h);
SetLength(tmp2, w * h);
s := img.PixelRow[0]; d := @tmp[0];
for j := 0 to h-1 do
begin
s2 := IncPColor32(s, 1);
for i := 0 to w-2 do
begin
d.A := ColorDifference(s^, s2^);
inc(s); inc(s2); inc(d);
end;
inc(s); inc(d);
end;
for j := 0 to w-1 do
begin
s := @tmp[j]; d := @tmp2[j];
s2 := IncPColor32(s, w);
for i := 0 to h-2 do
begin
d.A := AlphaAverage(s^, s2^);
inc(s, w); inc(s2, w); inc(d, w);
end;
end;
Move(tmp2[0], img.PixelBase^, w * h * sizeOf(TColor32));
if intensity < 1 then Exit;
if intensity > 10 then
intensity := 10; // range = 1-10
img.ScaleAlpha(intensity);
end;
//------------------------------------------------------------------------------
// FLOODFILL - AND SUPPORT FUNCTIONS
//------------------------------------------------------------------------------
type
PFloodFillRec = ^TFloodFillRec;
TFloodFillRec = record
xLeft : Integer;
xRight : Integer;
y : Integer;
dirY : Integer;
next : PFloodFillRec;
end;
TFloodFillStack = class
first : PFloodFillRec;
maxY : integer;
constructor Create(maxY: integer);
destructor Destroy; override;
procedure Push(xLeft, xRight,y, direction: Integer);
procedure Pop(out xLeft, xRight,y, direction: Integer);
function IsEmpty: Boolean;
end;
TFloodFillMask = class
private
img : TImage32;
mask : TImage32;
colorsRow : PColor32Array;
maskRow : PColor32Array;
initialColor : TColor32;
compareFunc : TCompareFunctionEx;
tolerance : Integer;
public
function Execute(imgIn, imgMaskOut: TImage32; x,y: integer;
aTolerance: Byte = 0; compFunc: TCompareFunctionEx = nil): Boolean;
procedure SetCurrentY(y: Integer);
function IsMatch(x: Integer): Boolean;
end;
//------------------------------------------------------------------------------
// TFloodFillStack methods
//------------------------------------------------------------------------------
constructor TFloodFillStack.Create(maxY: integer);
begin
self.maxY := maxY;
end;
//------------------------------------------------------------------------------
destructor TFloodFillStack.Destroy;
var
ffr: PFloodFillRec;
begin
while assigned(first) do
begin
ffr := first;
first := first.next;
dispose(ffr);
end;
end;
//------------------------------------------------------------------------------
procedure TFloodFillStack.Push(xLeft, xRight, y, direction: Integer);
var
ffr: PFloodFillRec;
begin
if ((y <= 0) and (direction = -1)) or
((y >= maxY) and (direction = 1)) then Exit;
new(ffr);
ffr.xLeft := xLeft;
ffr.xRight := xRight;
ffr.y := y;
ffr.dirY := direction;
ffr.next := first;
first := ffr;
end;
//------------------------------------------------------------------------------
procedure TFloodFillStack.Pop(out xLeft, xRight, y, direction: Integer);
var
ffr: PFloodFillRec;
begin
xLeft := first.xLeft;
xRight := first.xRight;
direction := first.dirY;
y := first.y + direction;
ffr := first;
first := first.next;
dispose(ffr);
end;
//------------------------------------------------------------------------------
function TFloodFillStack.IsEmpty: Boolean;
begin
result := not assigned(first);
end;
//------------------------------------------------------------------------------
// TFloodFillMask methods
//------------------------------------------------------------------------------
function TFloodFillMask.Execute(imgIn, imgMaskOut: TImage32; x,y: integer;
aTolerance: Byte; compFunc: TCompareFunctionEx): Boolean;
var
ffs : TFloodFillStack;
w,h : integer;
xl, xr, xr2 : Integer;
maxX : Integer;
dirY : Integer;
begin
Result := Assigned(imgIn) and Assigned(imgMaskOut) and
InRange(x,0,imgIn.Width -1) and InRange(y,0,imgIn.Height -1);
if not Result then Exit;
w := imgIn.Width; h := imgIn.Height;
// make sure the mask is the size of the image
imgMaskOut.SetSize(w,h);
img := imgIn;
mask := imgMaskOut;
compareFunc := compFunc;
tolerance := aTolerance;
maxX := w -1;
ffs := TFloodFillStack.create(h -1);
try
initialColor := imgIn.Pixel[x, y];
xl := x; xr := x;
SetCurrentY(y);
IsMatch(x);
while (xl > 0) and IsMatch(xl -1) do dec(xl);
while (xr < maxX) and IsMatch(xr +1) do inc(xr);
ffs.Push(xl, xr, y, -1); // down
ffs.Push(xl, xr, y, 1); // up
while not ffs.IsEmpty do
begin
ffs.Pop(xl, xr, y, dirY);
SetCurrentY(y);
xr2 := xl;
// check left ...
if IsMatch(xl) then
begin
while (xl > 0) and IsMatch(xl-1) do dec(xl);
if xl <= xr2 -2 then
ffs.Push(xl, xr2-2, y, -dirY);
while (xr2 < maxX) and IsMatch(xr2+1) do inc(xr2);
ffs.Push(xl, xr2, y, dirY);
if xr2 >= xr +2 then
ffs.Push(xr+2, xr2, y, -dirY);
xl := xr2 +2;
end;
// check right ...
while (xl <= xr) and not IsMatch(xl) do inc(xl);
while (xl <= xr) do
begin
xr2 := xl;
while (xr2 < maxX) and IsMatch(xr2+1) do inc(xr2);
ffs.Push(xl, xr2, y, dirY);
if xr2 >= xr +2 then
begin
ffs.Push(xr+2, xr2, y, -dirY);
break;
end;
inc(xl, 2);
while (xl <= xr) and not IsMatch(xl) do inc(xl);
end;
end;
finally
ffs.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TFloodFillMask.SetCurrentY(y: Integer);
begin
colorsRow := PColor32Array(img.PixelRow[y]);
maskRow := PColor32Array(mask.PixelRow[y]);
end;
//------------------------------------------------------------------------------
function TFloodFillMask.IsMatch(x: Integer): Boolean;
var
b: Byte;
begin
if (maskRow[x] > 0) then
result := false
else
begin
b := compareFunc(initialColor, colorsRow[x]);
result := b < tolerance;
if Result then
maskRow[x] := tolerance - b else
maskRow[x] := 1;
end;
end;
//------------------------------------------------------------------------------
function GetFloodFillMask(imgIn, imgMaskOut: TImage32; x, y: Integer;
tolerance: Byte; compareFunc: TCompareFunctionEx): Boolean;
var
ffm: TFloodFillMask;
begin
if not Assigned(compareFunc) then compareFunc := CompareRGBEx;
ffm := TFloodFillMask.Create;
try
Result := ffm.Execute(imgIn, imgMaskOut, x, y, tolerance, compareFunc);
finally
ffm.Free;
end;
end;
//------------------------------------------------------------------------------
procedure FloodFill(img: TImage32; x, y: Integer; newColor: TColor32;
tolerance: Byte; compareFunc: TCompareFunctionEx);
var
i: Integer;
pc, pm: PColor32;
mask: TImage32;
begin
if not assigned(compareFunc) then
begin
compareFunc := CompareRGBEx;
if tolerance = 0 then
tolerance := FloodFillDefaultRGBTolerance;
end;
mask := TImage32.Create;
try
if not GetFloodFillMask(img, mask, x, y, tolerance, compareFunc) then
Exit;
pc := img.PixelBase;
pm := mask.PixelBase;
for i := 0 to img.Width * img.Height -1 do
begin
if (pm^ > 1) then pc^ := newColor;
inc(pm); inc(pc);
end;
finally
mask.free;
end;
end;
//------------------------------------------------------------------------------
// EMBOSS - AND SUPPORT FUNCTIONS
//------------------------------------------------------------------------------
function IncPWeightColor(pwc: PWeightedColor; cnt: Integer): PWeightedColor;
begin
result := PWeightedColor(PByte(pwc) + cnt * SizeOf(TWeightedColor));
end;
//------------------------------------------------------------------------------
function Intensity(color: TColor32): byte;
var
c: TARGB absolute color;
begin
Result := (c.R * 61 + c.G * 174 + c.B * 21) shr 8;
end;
//------------------------------------------------------------------------------
function Gray(color: TColor32): TColor32;
var
c: TARGB absolute color;
res: TARGB absolute Result;
begin
res.A := c.A;
res.R := Intensity(color);
res.G := res.R;
res.B := res.R;
end;
//------------------------------------------------------------------------------
procedure Emboss(img: TImage32; radius: Integer;
depth: Integer; luminance: Integer; preserveColor: Boolean);
var
yy,xx, x,y, w,h: Integer;
b: byte;
kernel: array [0 .. MaxBlur, 0 .. MaxBlur] of Integer;
wca: TArrayOfWeightedColor;
pc0, pcf, pcb: PColor32; // pointers to pixels (forward & backward in kernel)
pw0, pw: PWeightedColor; // pointers to weight
customGray: TColor32;
pc: PColor32;
const
maxDepth = 50;
begin
// grayscale luminance as percent where 0% is black and 100% is white
//(luminance is ignored when preserveColor = true)
luminance := ClampRange(luminance, 0, 100);
b := luminance *255 div 100;
customGray := $FF000000 + b shl 16 + b shl 8 + b;
ClampRange(radius, 1, 5);
inc(depth);
ClampRange(depth, 2, maxDepth);
kernel[0][0] := 1;
for y := 1 to radius do
for x := 1 to radius do
kernel[y][x] := depth;
w := img.Width; h := img.Height;
// nb: dynamic arrays are zero-initialized (unless they're a function result)
SetLength(wca, w * h);
pc0 := IncPColor32(img.PixelBase, radius * w);
pw0 := @wca[radius * w];
for y := radius to h -1 - radius do
begin
for x := radius to w -1 - radius do
begin
pw := IncPWeightColor(pw0, x);
pcb := IncPColor32(pc0, x - 1);
if preserveColor then
begin
pcf := IncPColor32(pc0, x);
pw^.Add(pcf^, kernel[0,0]);
inc(pcf);
end else
begin
pw^.Add(customGray, kernel[0,0]);
pcf := IncPColor32(pc0, x + 1);
end;
// parse the kernel ...
for yy := 1 to radius do
begin
for xx := 1 to radius do
begin
pw^.Subtract(Gray(pcf^), kernel[yy,xx]);
pw^.Add(Gray(pcb^), kernel[yy,xx]);
dec(pcb); inc(pcf);
end;
dec(pcb, img.Width - radius);
inc(pcf, img.Width - radius);
end;
end;
inc(pc0, img.Width);
inc(pw0, img.Width);
end;
pc := @img.Pixels[0]; pw := @wca[0];
for x := 0 to img.width * img.Height - 1 do
begin
pc^ := pw.Color or $FF000000;
inc(pc); inc(pw);
end;
end;
//------------------------------------------------------------------------------
// Structure and functions used by the Vectorize routine
//------------------------------------------------------------------------------
type
TPt2Container = class;
TPt2 = class
pt : TPointD;
owner : TPt2Container;
isStart : Boolean;
isHole : Boolean;
nextInPath : TPt2;
prevInPath : TPt2;
nextInRow : TPt2;
prevInRow : TPt2;
destructor Destroy; override;
procedure Update(x, y: double);
function GetCount: integer;
function GetPoints: TPathD;
property IsAscending: Boolean read isStart;
end;
TPt2Container = class
prevRight: integer;
leftMostPt, rightMost: TPt2;
solution: TPathsD;
procedure AddToSolution(const path: TPathD);
function StartNewPath(insertBefore: TPt2;
xLeft, xRight, y: integer; isHole: Boolean): TPt2;
procedure AddRange(var current: TPt2; xLeft, xRight, y: integer);
function JoinAscDesc(path1, path2: TPt2): TPt2;
function JoinDescAsc(path1, path2: TPt2): TPt2;
procedure CheckRowEnds(pt2Left, pt2Right: TPt2);
end;
//------------------------------------------------------------------------------
destructor TPt2.Destroy;
var
startPt, endPt, pt: TPt2;
begin
if not isStart then Exit;
startPt := self;
endPt := startPt.prevInPath;
// remove 'endPt' from double linked list
if endPt = owner.rightMost then
owner.rightMost := endPt.prevInRow
else if assigned(endPt.nextInRow) then
endPt.nextInRow.prevInRow := endPt.prevInRow;
if endPt = owner.leftMostPt then
owner.leftMostPt := endPt.nextInRow
else if assigned(endPt.prevInRow) then
endPt.prevInRow.nextInRow := endPt.nextInRow;
// remove 'startPt' from double linked list
if startPt = owner.leftMostPt then
owner.leftMostPt := startPt.nextInRow
else if assigned(startPt.prevInRow) then
startPt.prevInRow.nextInRow := startPt.nextInRow;
if assigned(startPt.nextInRow) then
startPt.nextInRow.prevInRow := startPt.prevInRow;
owner.AddToSolution(GetPoints);
// now Free the entire path (except self)
pt := startPt.nextInPath;
while pt <> startPt do
begin
endPt := pt;
pt := pt.nextInPath;
endPt.Free;
end;
end;
//------------------------------------------------------------------------------
function IsColinear(const pt1, pt2, pt3: TPoint): Boolean; overload;
begin
// cross product = 0
result := (pt1.X - pt2.X)*(pt2.Y - pt3.Y) = (pt2.X - pt3.X)*(pt1.Y - pt2.Y);
end;
//------------------------------------------------------------------------------
function IsColinear(const pt1, pt2, pt3, pt4: TPoint): Boolean; overload;
begin
result := (pt1.X - pt2.X)*(pt3.Y - pt4.Y) = (pt3.X - pt4.X)*(pt1.Y - pt2.Y);
end;
//------------------------------------------------------------------------------
function CreatePt2After(pt: TPt2; const p: TPointD): TPt2;
begin
Result := TPt2.Create;
Result.pt := p;
Result.nextInPath := pt.nextInPath;
Result.prevInPath := pt;
pt.nextInPath.prevInPath := Result;
pt.nextInPath := Result;
end;
//------------------------------------------------------------------------------
procedure TPt2.Update(x, y: double);
var
newPt2: TPt2;
begin
if isStart then
begin
// just update self.pt when colinear
if (x = pt.X) and (pt.X = nextInPath.pt.X) then
begin
pt := PointD(x,y);
Exit;
end;
// self -> 2 -> 1 -> nip
CreatePt2After(self, pt);
if (x <> pt.X) or (x <> nextInPath.pt.X) then
begin
// add a pixel either below or beside
if IsAscending then
CreatePt2After(self, PointD(pt.X, y)) else
CreatePt2After(self, PointD(x, pt.Y));
end;
pt := PointD(x,y);
end else
begin
// just update self.pt when colinear
if (x = pt.X) and (pt.X = prevInPath.pt.X) then
begin
pt := PointD(x,y);
Exit;
end;
// self <- 2 <- 1 <- pip
newPt2 := CreatePt2After(prevInPath, pt);
if (x <> pt.X) or (x <> prevInPath.pt.X) then
begin
// add a pixel either below or beside
if IsAscending then
CreatePt2After(newPt2, PointD(x, pt.Y)) else
CreatePt2After(newPt2, PointD(pt.X, y));
end;
pt := PointD(x,y);
end;
end;
//------------------------------------------------------------------------------
function TPt2.GetCount: integer;
var
pt2: TPt2;
begin
result := 1;
pt2 := nextInPath;
while pt2 <> self do
begin
inc(Result);
pt2 := pt2.nextInPath;
end;
end;
//------------------------------------------------------------------------------
function TPt2.GetPoints: TPathD;
var
i, count: integer;
pt2: TPt2;
begin
Update(pt.X, pt.Y+1);
with prevInPath do Update(pt.X, pt.Y+1); // path 'end'
count := GetCount;
SetLength(Result, count);
pt2 := self;
for i := 0 to count -1 do
begin
Result[i] := pt2.pt;
pt2 := pt2.nextInPath;
end;
end;
//------------------------------------------------------------------------------
procedure TPt2Container.AddToSolution(const path: TPathD);
var
len: integer;
begin
if Length(path) < 2 then Exit;
len := Length(solution);
SetLength(solution, len + 1);
solution[len] := path;
end;
//------------------------------------------------------------------------------
function TPt2Container.StartNewPath(insertBefore: TPt2;
xLeft, xRight, y: integer; isHole: Boolean): TPt2;
var
pt2Left, pt2Right: TPt2;
begin
inc(xRight);
pt2Left := TPt2.Create;
pt2Left.owner := self;
pt2Left.isStart := not isHole;
pt2Left.isHole := isHole;
pt2Left.pt := PointD(xLeft, y);
pt2Right := TPt2.Create;
pt2Right.owner := self;
pt2Right.isStart := isHole;
pt2Right.isHole := isHole;
pt2Right.pt := PointD(xRight, y);
pt2Left.nextInPath := pt2Right;
pt2Left.prevInPath := pt2Right;
pt2Right.nextInPath := pt2Left;
pt2Right.prevInPath := pt2Left;
pt2Left.nextInRow := pt2Right;
pt2Right.prevInRow := pt2Left;
if not Assigned(insertBefore) then
begin
// must be a new rightMost path
pt2Left.prevInRow := rightMost;
if Assigned(rightMost) then rightMost.nextInRow := pt2Left;
pt2Right.nextInRow := nil;
rightMost := pt2Right;
if not Assigned(leftMostPt) then leftMostPt := pt2Left;
end else
begin
pt2Right.nextInRow := insertBefore;
if leftMostPt = insertBefore then
begin
// must be a new leftMostPt path
leftMostPt := pt2Left;
pt2Left.prevInRow := nil;
end else
begin
pt2Left.prevInRow := insertBefore.prevInRow;
insertBefore.prevInRow.nextInRow := pt2Left;
end;
insertBefore.prevInRow := pt2Right;
end;
result := pt2Right.nextInRow;
end;
//------------------------------------------------------------------------------
procedure TPt2Container.CheckRowEnds(pt2Left, pt2Right: TPt2);
begin
if pt2Left = leftMostPt then leftMostPt := pt2Right.nextInRow;
if pt2Right = rightMost then rightMost := pt2Left.prevInRow;
end;
//------------------------------------------------------------------------------
function TPt2Container.JoinAscDesc(path1, path2: TPt2): TPt2;
begin
result := path2.nextInRow;
CheckRowEnds(path1, path2);
if path2 = path1.prevInPath then
begin
path1.Free;
Exit;
end;
with path1 do Update(pt.X, pt.Y+1);
with path2 do Update(pt.X, pt.Y+1);
path1.isStart := false;
// remove path1 from double linked list
if assigned(path1.nextInRow) then
path1.nextInRow.prevInRow := path1.prevInRow;
if assigned(path1.prevInRow) then
path1.prevInRow.nextInRow := path1.nextInRow;
// remove path2 from double linked list
if assigned(path2.nextInRow) then
path2.nextInRow.prevInRow := path2.prevInRow;
if assigned(path2.prevInRow) then
path2.prevInRow.nextInRow := path2.nextInRow;
path1.prevInPath.nextInPath := path2.nextInPath;
path2.nextInPath.prevInPath := path1.prevInPath;
path2.nextInPath := path1;
path1.prevInPath := path2;
end;
//------------------------------------------------------------------------------
function TPt2Container.JoinDescAsc(path1, path2: TPt2): TPt2;
begin
result := path2.nextInRow;
CheckRowEnds(path1, path2);
if path1 = path2.prevInPath then
begin
path2.Free;
Exit;
end;
with path1 do Update(pt.X, pt.Y+1);
with path2 do Update(pt.X, pt.Y+1);
path2.isStart := false;
// remove path1 'end' from double linked list
if assigned(path1.nextInRow) then
path1.nextInRow.prevInRow := path1.prevInRow;
if assigned(path1.prevInRow) then
path1.prevInRow.nextInRow := path1.nextInRow;
// remove path2 'start' from double linked list
if assigned(path2.nextInRow) then
path2.nextInRow.prevInRow := path2.prevInRow;
if assigned(path2.prevInRow) then
path2.prevInRow.nextInRow := path2.nextInRow;
path1.nextInPath.prevInPath := path2.prevInPath;
path2.prevInPath.nextInPath := path1.nextInPath;
path1.nextInPath := path2;
path2.prevInPath := path1;
end;
//------------------------------------------------------------------------------
function IsHeadingLeft(current: TPt2; r: integer): Boolean;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result := r <= current.pt.X;
end;
//------------------------------------------------------------------------------
procedure TPt2Container.AddRange(var current: TPt2;
xLeft, xRight, y: integer);
begin
if (prevRight > 0) then
begin
// nb: prevRight always ends a range (whether a hole or an outer)
// check if we're about to start a hole
if xLeft < current.pt.X then
begin
//'current' must be descending and hence prevRight->xLeft a hole
current := StartNewPath(current, prevRight, xLeft -1, y, true);
prevRight := xRight;
Exit; // nb: it's possible for multiple holes
end;
// check if we're passing under a pending join
while assigned(current) and assigned(current.nextInRow) and
(prevRight > current.nextInRow.pt.X) do
begin
// Assert(not current.IsAscending, 'oops!');
// Assert(current.nextInRow.IsAscending, 'oops!');
current := JoinDescAsc(current, current.nextInRow);
end;
// check again for a new hole
if (xLeft < current.pt.X) then
begin
current := StartNewPath(current, prevRight, xLeft -1, y, true);
prevRight := xRight;
Exit;
end;
current.Update(prevRight, y);
current := current.nextInRow;
prevRight := 0;
end;
// check if we're passing under a pending join
while assigned(current) and assigned(current.nextInRow) and
(xLeft > current.nextInRow.pt.X) do
current := JoinAscDesc(current, current.nextInRow);
if not assigned(current) or (xRight < current.pt.X) then
begin
StartNewPath(current, xLeft, xRight -1, y, false);
// nb: current remains unchanged
end else
begin
//'range' must somewhat overlap one or more paths above
if IsHeadingLeft(current, xRight) then
begin
if current.isHole then
begin
current.Update(xLeft, y);
current := current.nextInRow;
end;
current.Update(xRight, y);
current.Update(xLeft, y);
if current.IsAscending then
prevRight := xRight else
prevRight := 0;
current := current.nextInRow;
end else
begin
current.Update(xLeft, y);
current := current.nextInRow;
prevRight := xRight;
end;
end
end;
//------------------------------------------------------------------------------
function VectorizeMask(const mask: TArrayOfByte; maskWidth: integer): TPathsD;
var
i,j, len, height, blockStart: integer;
current: TPt2;
ba: PByteArray;
pt2Container: TPt2Container;
begin
Result := nil;
len := Length(mask);
if (len = 0) or (maskWidth = 0) or (len mod maskWidth <> 0) then Exit;
height := len div maskWidth;
pt2Container := TPt2Container.Create;
try
for i := 0 to height -1 do
begin
ba := @mask[maskWidth * i];
blockStart := -2;
current := pt2Container.leftMostPt;
for j := 0 to maskWidth -1 do
begin
if (ba[j] > 0) = (blockStart >= 0) then Continue;
if blockStart >= 0 then
begin
pt2Container.AddRange(current, blockStart, j, i);
blockStart := -1;
end else
blockStart := j;
end;
if blockStart >= 0 then
pt2Container.AddRange(current, blockStart, maskWidth, i);
if (pt2Container.prevRight > 0) then
begin
while Assigned(current.nextInRow) and
(pt2Container.prevRight >= current.nextInRow.pt.X) do
begin
if current.isStart then
current := pt2Container.JoinAscDesc(current, current.nextInRow)
else
current := pt2Container.JoinDescAsc(current, current.nextInRow);
end;
current.Update(pt2Container.prevRight, i);
current := current.nextInRow;
pt2Container.prevRight := 0;
end;
while assigned(current) do
begin
if current.isStart then
current := pt2Container.JoinAscDesc(current, current.nextInRow) else
current := pt2Container.JoinDescAsc(current, current.nextInRow);
end
end;
with pt2Container do
while Assigned(leftMostPt) do
if leftMostPt.isStart then
JoinAscDesc(leftMostPt, leftMostPt.nextInRow) else
JoinDescAsc(leftMostPt, leftMostPt.nextInRow);
Result := pt2Container.solution;
finally
pt2Container.Free;
end;
end;
//------------------------------------------------------------------------------
function Tidy(const poly: TPathD; tolerance: integer): TPathD;
var
i,j, highI: integer;
prev: TPointD;
tolSqrd: double;
begin
Result := nil;
highI := High(poly);
while (HighI >= 0) and PointsEqual(poly[highI], poly[0]) do dec(highI);
if highI < 1 then Exit;
tolSqrd := Sqr(Max(2.02, Min(16.1, tolerance + 0.01)));
SetLength(Result, highI +1);
prev := poly[highI];
Result[0] := prev;
Result[1] := poly[0];
j := 1;
for i := 1 to highI -1 do
begin
if ((DistanceSqrd(prev, Result[j]) > tolSqrd) and
(DistanceSqrd(Result[j], poly[i]) > tolSqrd)) or
(TurnsRight(prev, result[j], poly[i]) or
TurnsLeft(result[j], poly[i], poly[i+1])) then
begin
prev := result[j];
inc(j);
end;
result[j] := poly[i];
end;
if ((DistanceSqrd(prev, Result[j]) > tolSqrd) and
(DistanceSqrd(Result[j], Result[0]) > tolSqrd)) or
TurnsRight(prev, result[j], Result[0]) or
TurnsLeft(result[j], Result[0], Result[1]) then
SetLength(Result, j +1) else
SetLength(Result, j);
if Abs(Area(Result)) < Length(Result) * tolerance/2 then Result := nil;
end;
//------------------------------------------------------------------------------
function Vectorize(img: TImage32; compareColor: TColor32;
compareFunc: TCompareFunction; colorTolerance: Integer;
roundingTolerance: integer): TPathsD;
var
i,j: integer;
mask: TArrayOfByte;
begin
mask := GetBoolMask(img, compareColor, compareFunc, colorTolerance);
Result := VectorizeMask(mask, img.Width);
j := 0;
for i := 0 to high(Result) do
begin
Result[j] := Tidy(Result[i], roundingTolerance);
if Assigned(Result[j]) then inc(j);
end;
SetLength(Result, j);
end;
//------------------------------------------------------------------------------
// RamerDouglasPeucker - and support functions
//------------------------------------------------------------------------------
procedure RDP(const path: TPathD; startIdx, endIdx: integer;
epsilonSqrd: double; var flags: TArrayOfInteger);
var
i, idx: integer;
d, maxD: double;
begin
idx := 0;
maxD := 0;
for i := startIdx +1 to endIdx -1 do
begin
// PerpendicularDistSqrd - avoids expensive Sqrt()
d := PerpendicularDistSqrd(path[i], path[startIdx], path[endIdx]);
if d <= maxD then Continue;
maxD := d;
idx := i;
end;
if maxD < epsilonSqrd then Exit;
flags[idx] := 1;
if idx > startIdx + 1 then RDP(path, startIdx, idx, epsilonSqrd, flags);
if endIdx > idx + 1 then RDP(path, idx, endIdx, epsilonSqrd, flags);
end;
//------------------------------------------------------------------------------
function RamerDouglasPeucker(const path: TPathD;
epsilon: double): TPathD;
var
i,j, len: integer;
buffer: TArrayOfInteger;
begin
len := length(path);
if len < 5 then
begin
result := Copy(path, 0, len);
Exit;
end;
SetLength(buffer, len); // buffer is zero initialized
buffer[0] := 1;
buffer[len -1] := 1;
RDP(path, 0, len -1, Sqr(epsilon), buffer);
j := 0;
SetLength(Result, len);
for i := 0 to len -1 do
if buffer[i] = 1 then
begin
Result[j] := path[i];
inc(j);
end;
SetLength(Result, j);
end;
//------------------------------------------------------------------------------
function RamerDouglasPeucker(const paths: TPathsD;
epsilon: double): TPathsD;
var
i,j, len: integer;
begin
j := 0;
len := length(paths);
setLength(Result, len);
for i := 0 to len -1 do
begin
Result[j] := RamerDouglasPeucker(paths[i], epsilon);
if Result[j] <> nil then inc(j);
end;
setLength(Result, j);
end;
//------------------------------------------------------------------------------
function DotProdVecs(const vec1, vec2: TPointD): double;
{$IFDEF INLINE} inline; {$ENDIF}
begin
result := (vec1.X * vec2.X + vec1.Y * vec2.Y);
end;
//---------------------------------------------------------------------------
function SmoothToCubicBezier(const path: TPathD;
pathIsClosed: Boolean; maxOffset: integer): TPathD;
var
i, j, len, prev: integer;
vec: TPointD;
pl: TArrayOfDouble;
unitVecs: TPathD;
d, angle, d1,d2: double;
begin
// SmoothToCubicBezier - returns cubic bezier control points
Result := nil;
len := Length(path);
if len < 3 then Exit;
SetLength(Result, len *3 +1);
prev := len-1;
SetLength(pl, len);
SetLength(unitVecs, len);
pl[0] := Distance(path[prev], path[0]);
unitVecs[0] := GetUnitVector(path[prev], path[0]);
for i := 0 to len -1 do
begin
if i = prev then
begin
j := 0;
end else
begin
j := i +1;
pl[j] := Distance(path[i], path[j]);
unitVecs[j] := GetUnitVector(path[i], path[j]);
end;
vec := GetAvgUnitVector(unitVecs[i], unitVecs[j]);
angle := arccos(Max(-1,Min(1,(DotProdVecs(unitVecs[i], unitVecs[j])))));
d := abs(Pi-angle)/TwoPi;
d1 := pl[i] * d;
d2 := pl[j] * d;
if maxOffset > 0 then
begin
d1 := Min(maxOffset, d1);
d2 := Min(maxOffset, d2);
end;
if i = 0 then
Result[len*3-1] := OffsetPoint(path[0], -vec.X * d1, -vec.Y * d1)
else
Result[i*3-1] := OffsetPoint(path[i], -vec.X * d1, -vec.Y * d1);
Result[i*3] := path[i];
Result[i*3+1] := OffsetPoint(path[i], vec.X * d2, vec.Y * d2);
end;
Result[len*3] := path[0];
if pathIsClosed then Exit;
Result[1] := Result[0];
dec(len);
Result[len*3-1] := Result[len*3];
SetLength(Result, Len*3 +1);
end;
//------------------------------------------------------------------------------
function HermiteInterpolation(y1, y2, y3, y4: double;
mu, tension: double): double;
var
m0,m1,mu2,mu3: double;
a0,a1,a2,a3: double;
begin
// http://paulbourke.net/miscellaneous/interpolation/
// nb: optional bias toward left or right has been disabled.
mu2 := mu * mu;
mu3 := mu2 * mu;
m0 := (y2-y1)*(1-tension)/2;
m0 := m0 + (y3-y2)*(1-tension)/2;
m1 := (y3-y2)*(1-tension)/2;
m1 := m1 + (y4-y3)*(1-tension)/2;
a0 := 2*mu3 - 3*mu2 + 1;
a1 := mu3 - 2*mu2 + mu;
a2 := mu3 - mu2;
a3 := -2*mu3 + 3*mu2;
Result := a0*y2+a1*m0+a2*m1+a3*y3;
end;
//------------------------------------------------------------------------------
function InterpolateY(const y1,y2,y3,y4: double;
dx: integer; tension: double): TArrayOfDouble;
var
i: integer;
begin
SetLength(Result, dx);
if dx = 0 then Exit;
Result[0] := y2;
for i := 1 to dx-1 do
Result[i] := HermiteInterpolation(y1,y2,y3,y4, i/dx, tension);
end;
//------------------------------------------------------------------------------
function InterpolatePoints(const points: TPathD; tension: integer): TPathD;
var
i, j, len, len2: integer;
p, p2: TPathD;
ys: TArrayOfDouble;
begin
if tension < -1 then tension := -1
else if tension > 1 then tension := 1;
Result := nil;
len := Length(points);
if len < 2 then Exit;
SetLength(p, len +2);
p[0] := points[0];
p[len+1] := points[len -1];
Move(points[0],p[1], len * SizeOf(TPointD));
for i := 1 to len-1 do
begin
ys := InterpolateY(p[i-1].Y,p[i].Y,p[i+1].Y,p[i+2].Y,
Trunc(p[i+1].X - p[i].X), tension);
len2 := Length(ys);
SetLength(p2, len2);
for j := 0 to len2 -1 do
p2[j] := PointD(p[i].X +j, ys[j]);
AppendPath(Result, p2);
end;
AppendPoint(Result, p[len]);
end;
//------------------------------------------------------------------------------
// GaussianBlur
//------------------------------------------------------------------------------
procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer);
var
i, w,h, x,y,yy,z: Integer;
gaussTable: array [-MaxBlur .. MaxBlur] of Cardinal;
wc: TWeightedColor;
wca: TArrayOfWeightedColor;
row: PColor32Array;
wcRow: PWeightedColorArray;
begin
Types.IntersectRect(rec, rec, img.Bounds);
if IsEmptyRect(rec) or (radius < 1) then Exit
else if radius > MaxBlur then radius := MaxBlur;
for i := 0 to radius do
begin
gaussTable[i] := Sqr(Radius - i +1);
gaussTable[-i] := gaussTable[i];
end;
RectWidthHeight(rec, w, h);
setLength(wca, w * h);
for y := 0 to h -1 do
begin
row := PColor32Array(@img.Pixels[(y + rec.Top) * img.Width + rec.Left]);
wcRow := PWeightedColorArray(@wca[y * w]);
for x := 0 to w -1 do
for z := max(0, x - radius) to min(img.Width -1, x + radius) do
wcRow[x].Add(row[z], gaussTable[x-z]);
end;
for x := 0 to w -1 do
begin
for y := 0 to h -1 do
begin
wc.Reset;
yy := max(0, y - radius) * w;
for z := max(0, y - radius) to min(h -1, y + radius) do
begin
wc.Add(wca[x + yy].Color, gaussTable[y-z]);
inc(yy, w);
end;
img.Pixels[x + rec.Left + (y + rec.Top) * img.Width] := wc.Color;
end;
end;
end;
//------------------------------------------------------------------------------
// FastGaussian blur - and support functions
//------------------------------------------------------------------------------
//http://blog.ivank.net/fastest-gaussian-blur.html
//https://www.peterkovesi.com/papers/FastGaussianSmoothing.pdf
function BoxesForGauss(stdDev, boxCnt: integer): TArrayOfInteger;
var
i, wl, wu, m: integer;
wIdeal, mIdeal: double;
begin
SetLength(Result, boxCnt);
wIdeal := Sqrt((12*stdDev*stdDev/boxCnt)+1); // Ideal averaging filter width
wl := Floor(wIdeal); if not Odd(wl) then dec(wl);
mIdeal :=
(-3*stdDev*stdDev +0.25*boxCnt*wl*wl +boxCnt*wl +0.75*boxCnt)/(wl+1);
m := Floor(mIdeal) div 2; // nb: variation on Ivan Kutskir's code.
wl := (wl -1) div 2; // It's better to do this here
wu := wl+1; // than later in both BoxBlurH & BoxBlurV
for i := 0 to boxCnt -1 do
if i < m then
Result[i] := wl else
Result[i] := wu;
end;
//------------------------------------------------------------------------------
procedure BoxBlurH(var src, dst: TArrayOfColor32; w,h, stdDev: integer);
var
i,j, ti, li, ri, re, ovr: integer;
fv, lv, val: TWeightedColor;
rc: TColor32;
begin
ovr := Max(0, stdDev - w);
for i := 0 to h -1 do
begin
ti := i * w;
li := ti;
ri := ti +stdDev;
re := ti +w -1; // idx of last pixel in row
rc := src[re]; // color of last pixel in row
fv.Reset;
lv.Reset;
val.Reset;
fv.Add(src[ti], 1);
lv.Add(rc, 1);
val.Add(src[ti], stdDev +1);
for j := 0 to stdDev -1 - ovr do
val.Add(src[ti + j]);
if ovr > 0 then val.Add(rc, ovr);
for j := 0 to stdDev do
begin
if ri > re then
val.Add(rc) else
val.Add(src[ri]);
inc(ri);
val.Subtract(fv);
if ti <= re then
dst[ti] := val.Color;
inc(ti);
end;
for j := stdDev +1 to w - stdDev -1 do
begin
if ri <= re then
begin
val.Add(src[ri]); inc(ri);
val.Subtract(src[li]); inc(li);
end;
dst[ti] := val.Color; inc(ti);
end;
while ti <= re do
begin
if ti > re then Break;
val.Add(lv);
val.Subtract(src[li]); inc(li);
dst[ti] := val.Color;
inc(ti);
end;
end;
end;
//------------------------------------------------------------------------------
procedure BoxBlurV(var src, dst: TArrayOfColor32; w, h, stdDev: integer);
var
i,j, ti, li, ri, re, ovr: integer;
fv, lv, val: TWeightedColor;
rc: TColor32;
begin
ovr := Max(0, stdDev - h);
for i := 0 to w -1 do
begin
ti := i;
li := ti;
ri := ti + stdDev * w;
fv.Reset;
lv.Reset;
val.Reset;
re := ti +w *(h-1); // idx of last pixel in column
rc := src[re]; // color of last pixel in column
fv.Add(src[ti]);
lv.Add(rc, 1);
val.Add(src[ti], stdDev +1);
for j := 0 to stdDev -1 -ovr do
val.Add(src[ti + j *w]);
if ovr > 0 then val.Add(rc, ovr);
for j := 0 to stdDev do
begin
if ri > re then
val.Add(rc) else
val.Add(src[ri]);
inc(ri, w);
val.Subtract(fv);
if ti <= re then
dst[ti] := val.Color;
inc(ti, w);
end;
for j := stdDev +1 to h - stdDev -1 do
begin
if ri <= re then
begin
val.Add(src[ri]); inc(ri, w);
val.Subtract(src[li]); inc(li, w);
end;
dst[ti] := val.Color; inc(ti, w);
end;
while ti <= re do
begin
val.Add(lv);
val.Subtract(src[li]); inc(li, w);
dst[ti] := val.Color;
inc(ti, w);
end;
end;
end;
//------------------------------------------------------------------------------
procedure FastGaussianBlur(img: TImage32;
const rec: TRect; stdDev: integer; repeats: integer);
begin
FastGaussianBlur(img, rec, stdDev, stdDev, repeats);
end;
//------------------------------------------------------------------------------
procedure FastGaussianBlur(img: TImage32;
const rec: TRect; stdDevX, stdDevY: integer; repeats: integer);
var
i,j,len, w,h: integer;
rec2: TRect;
boxesH: TArrayOfInteger;
boxesV: TArrayOfInteger;
src, dst: TArrayOfColor32;
blurFullImage: Boolean;
pSrc, pDst: PColor32;
begin
if not Assigned(img) then Exit;
Types.IntersectRect(rec2, rec, img.Bounds);
if IsEmptyRect(rec2) then Exit;
blurFullImage := RectsEqual(rec2, img.Bounds);
RectWidthHeight(rec2, w, h);
if (Min(w, h) < 2) or ((stdDevX < 1) and (stdDevY < 1)) then Exit;
len := w * h;
SetLength(src, len);
SetLength(dst, len);
if blurFullImage then
begin
// copy the entire image into 'dst'
Move(img.PixelBase^, dst[0], len * SizeOf(TColor32));
end else
begin
// copy a rectangular region into 'dst'
pSrc := img.PixelRow[rec2.Top];
inc(pSrc, rec2.Left);
pDst := @dst[0];
for i := 0 to h -1 do
begin
Move(pSrc^, pDst^, w * SizeOf(TColor32));
inc(pSrc, img.Width);
inc(pDst, w);
end;
end;
// do the blur
inc(repeats); // now represents total iterations
boxesH := BoxesForGauss(stdDevX, repeats);
if stdDevY = stdDevX then
boxesV := boxesH else
boxesV := BoxesForGauss(stdDevY, repeats);
for j := 0 to repeats -1 do
begin
BoxBlurH(dst, src, w, h, boxesH[j]);
BoxBlurV(src, dst, w, h, boxesV[j]);
end;
// copy dst array back to image rect
img.BeginUpdate;
try
if blurFullImage then
begin
Move(dst[0], img.PixelBase^, len * SizeOf(TColor32));
end else
begin
pDst := img.PixelRow[rec2.Top];
inc(pDst, rec2.Left);
pSrc := @dst[0];
for i := 0 to h -1 do
begin
Move(pSrc^, pDst^, w * SizeOf(TColor32));
inc(pSrc, w);
inc(pDst, img.Width);
end;
end;
finally
img.EndUpdate;
end;
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
// CurveFit() support structures and functions
//------------------------------------------------------------------------------
//CurveFit: this function is based on -
//"An Algorithm for Automatically Fitting Digitized Curves"
//by Philip J. Schneider in "Graphics Gems", Academic Press, 1990
//Smooths out many very closely positioned points
//tolerance range: 1..10 where 10 == max tolerance.
//This function has been archived as I believe that
//RamerDouglasPeuker(), GetSmoothPath() and FlattenCBezier()
//will usually achieve a better result
function Scale(const vec: TPointD; newLen: double): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result.X := vec.X * newLen;
Result.Y := vec.Y * newLen;
end;
//------------------------------------------------------------------------------
function Mul(const vec: TPointD; val: double): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result.X := vec.X * val;
Result.Y := vec.Y * val;
end;
//------------------------------------------------------------------------------
function AddVecs(const vec1, vec2: TPointD): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result.X := vec1.X + vec2.X;
Result.Y := vec1.Y + vec2.Y;
end;
//------------------------------------------------------------------------------
function SubVecs(const vec1, vec2: TPointD): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result.X := vec1.X - vec2.X;
Result.Y := vec1.Y - vec2.Y;
end;
//------------------------------------------------------------------------------
function NormalizeVec(const vec: TPointD): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
var
len: double;
begin
len := Sqrt(vec.X * vec.X + vec.Y * vec.Y);
if len <> 0 then
begin
Result.X := vec.X / len;
Result.Y := vec.Y / len;
end else
result := vec;
end;
//------------------------------------------------------------------------------
function NormalizeTPt(const pt: PPt): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
with pt^ do
if len <> 0 then
begin
Result.X := vec.X / len;
Result.Y := vec.Y / len;
end else
result := vec;
end;
//------------------------------------------------------------------------------
function NegateVec(vec: TPointD): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result.X := -vec.X;
Result.Y := -vec.Y;
end;
//------------------------------------------------------------------------------
function B0(u: double): double; {$IFDEF INLINE} inline; {$ENDIF}
var
tmp: double;
begin
tmp := 1.0 - u;
result := tmp * tmp * tmp;
end;
//------------------------------------------------------------------------------
function B1(u: double): double; {$IFDEF INLINE} inline; {$ENDIF}
var
tmp: double;
begin
tmp := 1.0 - u;
result := 3 * u * tmp * tmp;
end;
//------------------------------------------------------------------------------
function B2(u: double): double; {$IFDEF INLINE} inline; {$ENDIF}
begin
result := 3 * u * u * (1.0 - u);
end;
//------------------------------------------------------------------------------
function B3(u: double): double; {$IFDEF INLINE} inline; {$ENDIF}
begin
result := u * u * u;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.AddPt(const pt: TPointD): PPt;
begin
new(Result);
Result.pt := pt;
if not assigned(ppts) then
begin
Result.prev := Result;
Result.next := Result;
ppts := Result;
end else
begin
Result.prev := ppts.prev;
ppts.prev.next := Result;
ppts.prev := Result;
Result.next := ppts;
end;
end;
//------------------------------------------------------------------------------
procedure TFitCurveContainer.Clear;
var
p: PPt;
begin
solution := nil;
ppts.prev.next := nil; //break loop
while assigned(ppts) do
begin
p := ppts;
ppts := ppts.next;
Dispose(p);
end;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.Count(first, last: PPt): integer;
begin
if first = last then
result := 0 else
result := 1;
repeat
inc(Result);
first := first.next;
until (first = last);
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.ComputeLeftTangent(p: PPt): TPointD;
begin
Result := NormalizeTPt(p);
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.ComputeRightTangent(p: PPt): TPointD;
begin
Result := NegateVec(NormalizeTPt(p.prev));
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.ComputeCenterTangent(p: PPt): TPointD;
var
v1, v2: TPointD;
begin
v1 := SubVecs(p.pt, p.prev.pt);
v2 := SubVecs(p.next.pt, p.pt);
Result := AddVecs(v1, v2);
Result := NormalizeVec(Result);
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.ChordLengthParameterize(
first: PPt; cnt: integer): TArrayOfDouble;
var
d: double;
i: integer;
begin
SetLength(Result, cnt);
Result[0] := 0;
d := 0;
for i := 1 to cnt -1 do
begin
d := d + first.len;
Result[i] := d;
first := first.next;
end;
for i := 1 to cnt -1 do
Result[i] := Result[i] / d;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.GenerateBezier(first, last: PPt; cnt: integer;
const u: TArrayOfDouble; const firstTan, lastTan: TPointD): TPathD;
var
i: integer;
p: PPt;
dist, epsilon: double;
v1,v2, tmp: TPointD;
a0, a1: TPathD;
c: array [0..1, 0..1] of double;
x: array [0..1] of double;
det_c0_c1, det_c0_x, det_x_c1, alphaL, alphaR: double;
begin
SetLength(a0, cnt);
SetLength(a1, cnt);
dist := Distance(first.pt, last.pt);
for i := 0 to cnt -1 do
begin
v1 := Scale(firstTan, B1(u[i]));
v2 := Scale(lastTan, B2(u[i]));
a0[i] := v1;
a1[i] := v2;
end;
FillChar(c[0][0], 4 * SizeOf(double), 0);
FillChar(x[0], 2 * SizeOf(double), 0);
p := first;
for i := 0 to cnt -1 do
begin
c[0][0] := c[0][0] + DotProdVecs(a0[i], (a0[i]));
c[0][1] := c[0][1] + DotProdVecs(a0[i], (a1[i]));
c[1][0] := c[0][1];
c[1][1] := c[1][1] + DotProdVecs(a1[i], (a1[i]));
tmp := SubVecs(p.pt,
AddVecs(Mul(first.pt, B0(u[i])),
AddVecs(Mul(first.pt, B1(u[i])),
AddVecs(Mul(last.pt, B2(u[i])),
Mul(last.pt, B3(u[i]))))));
x[0] := x[0] + DotProdVecs(a0[i], tmp);
x[1] := x[1] + DotProdVecs(a1[i], tmp);
p := p.next;
end;
det_c0_c1 := c[0][0] * c[1][1] - c[1][0] * c[0][1];
det_c0_x := c[0][0] * x[1] - c[1][0] * x[0];
det_x_c1 := x[0] * c[1][1] - x[1] * c[0][1];
if det_c0_c1 = 0 then
alphaL := 0 else
alphaL := det_x_c1 / det_c0_c1;
if det_c0_c1 = 0 then
alphaR := 0 else
alphaR := det_c0_x / det_c0_c1;
//check for unlikely fit
if (alphaL > dist * 2) then alphaL := 0
else if (alphaR > dist * 2) then alphaR := 0;
epsilon := 1.0e-6 * dist;
SetLength(Result, 4);
Result[0] := first.pt;
Result[3] := last.pt;
if (alphaL < epsilon) or (alphaR < epsilon) then
begin
dist := dist / 3;
Result[1] := AddVecs(Result[0], Scale(firstTan, dist));
Result[2] := AddVecs(Result[3], Scale(lastTan, dist));
end else
begin
Result[1] := AddVecs(Result[0], Scale(firstTan, alphaL));
Result[2] := AddVecs(Result[3], Scale(lastTan, alphaR));
end;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.Reparameterize(first: PPt; cnt: integer;
const u: TArrayOfDouble; const bezier: TPathD): TArrayOfDouble;
var
i: integer;
begin
SetLength(Result, cnt);
for i := 0 to cnt -1 do
begin
Result[i] := NewtonRaphsonRootFind(bezier, first.pt, u[i]);
first := first.next;
end;
end;
//------------------------------------------------------------------------------
function BezierII(degree: integer; const v: array of TPointD; t: double): TPointD;
var
i,j: integer;
tmp: array[0..3] of TPointD;
begin
Move(v[0], tmp[0], degree * sizeOf(TPointD));
for i := 1 to degree do
for j := 0 to degree - i do
begin
tmp[j].x := (1.0 - t) * tmp[j].x + t * tmp[j+1].x;
tmp[j].y := (1.0 - t) * tmp[j].y + t * tmp[j+1].y;
end;
Result := tmp[0];
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.ComputeMaxErrorSqrd(first, last: PPt;
const bezier: TPathD; const u: TArrayOfDouble;
out SplitPoint: PPt): double;
var
i: integer;
distSqrd: double;
pt: TPointD;
p: PPt;
begin
Result := 0;
i := 1;
SplitPoint := first.next;
p := first.next;
while p <> last do
begin
pt := BezierII(3, bezier, u[i]);
distSqrd := DistanceSqrd(pt, p.pt);
if (distSqrd >= Result) then
begin
Result := distSqrd;
SplitPoint := p;
end;
inc(i);
p := p.next;
end;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.NewtonRaphsonRootFind(const q: TPathD;
const pt: TPointD; u: double): double;
var
numerator, denominator: double;
qu, q1u, q2u: TPointD;
q1: array[0..2] of TPointD;
q2: array[0..1] of TPointD;
begin
q1[0].x := (q[1].x - q[0].x) * 3.0;
q1[0].y := (q[1].y - q[0].y) * 3.0;
q1[1].x := (q[2].x - q[1].x) * 3.0;
q1[1].y := (q[2].y - q[1].y) * 3.0;
q1[2].x := (q[3].x - q[2].x) * 3.0;
q1[2].y := (q[3].y - q[2].y) * 3.0;
q2[0].x := (q1[1].x - q1[0].x) * 2.0;
q2[0].y := (q1[1].y - q1[0].y) * 2.0;
q2[1].x := (q1[2].x - q1[1].x) * 2.0;
q2[1].y := (q1[2].y - q1[1].y) * 2.0;
qu := BezierII(3, q, u);
q1u := BezierII(2, q1, u);
q2u := BezierII(1, q2, u);
numerator := (qu.x - pt.x) * (q1u.x) + (qu.y - pt.y) * (q1u.y);
denominator := (q1u.x) * (q1u.x) + (q1u.y) * (q1u.y) +
(qu.x - pt.x) * (q2u.x) + (qu.y - pt.y) * (q2u.y);
if (denominator = 0) then
Result := u else
Result := u - (numerator / denominator);
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.FitCubic(first, last: PPt;
firstTan, lastTan: TPointD): Boolean;
var
i, cnt: integer;
splitPoint: PPt;
centerTan: TPointD;
bezier: TPathD;
clps, uPrime: TArrayOfDouble;
maxErrorSqrd: double;
const
maxRetries = 4;
begin
Result := true;
cnt := Count(first, last);
if cnt = 2 then
begin
SetLength(bezier, 4);
bezier[0] := first.pt;
bezier[3] := last.pt;
bezier[1] := bezier[0];
bezier[2] := bezier[3];
AppendSolution(bezier);
Exit;
end
else if cnt = 3 then
begin
if TurnsLeft(first.prev.pt, first.pt, first.next.pt) =
TurnsLeft(first.pt, first.next.pt, last.pt) then
firstTan := ComputeCenterTangent(first);
if TurnsLeft(last.prev.pt, last.pt, last.next.pt) =
TurnsLeft(first.pt, first.next.pt, last.pt) then
lastTan := NegateVec(ComputeCenterTangent(last));
end;
clps := ChordLengthParameterize(first, cnt);
bezier := GenerateBezier(first, last, cnt, clps, firstTan, lastTan);
maxErrorSqrd := ComputeMaxErrorSqrd(first, last, bezier, clps, splitPoint);
if (maxErrorSqrd < tolSqrd) then
begin
AppendSolution(bezier);
Exit;
end;
if (maxErrorSqrd < tolSqrd * 4) then //close enough to try again
begin
for i := 1 to maxRetries do
begin
uPrime := Reparameterize(first, cnt, clps, bezier);
bezier := GenerateBezier(first, last, cnt, uPrime, firstTan, lastTan);
maxErrorSqrd :=
ComputeMaxErrorSqrd(first, last, bezier, uPrime, splitPoint);
if (maxErrorSqrd < tolSqrd) then
begin
AppendSolution(bezier);
Exit;
end;
clps := uPrime;
end;
end;
//We need to break the curve because it's too complex for a single Bezier.
//If we're changing direction then make this a 'hard' break (see below).
if TurnsLeft(splitPoint.prev.prev.pt, splitPoint.prev.pt, splitPoint.pt) <>
TurnsLeft(splitPoint.prev.pt, splitPoint.pt, splitPoint.next.pt) then
begin
centerTan := ComputeRightTangent(splitPoint);
FitCubic(first, splitPoint, firstTan, centerTan);
centerTan := ComputeLeftTangent(splitPoint);
FitCubic(splitPoint, last, centerTan, lastTan);
end else
begin
centerTan := ComputeCenterTangent(splitPoint);
FitCubic(first, splitPoint, firstTan, NegateVec(centerTan));
FitCubic(splitPoint, last, centerTan, lastTan);
end;
end;
//------------------------------------------------------------------------------
function HardBreakCheck(ppt: PPt; compareLen: double): Boolean;
var
q: double;
const
longLen = 15;
begin
//A 'break' means starting a new Bezier. A 'hard' break avoids smoothing
//whereas a 'soft' break will still be smoothed. There is as much art as
//science in determining where to smooth and where not to. For example,
//long edges should generally remain straight but how long does an edge
//have to be to be considered a 'long' edge?
if (ppt.prev.len * 4 < ppt.len) or (ppt.len * 4 < ppt.prev.len) then
begin
//We'll hard break whenever there's significant asymmetry between
//segment lengths because GenerateBezier() will perform poorly.
result := true;
end
else if ((ppt.prev.len > longLen) and (ppt.len > longLen)) then
begin
//hard break long segments only when turning by more than ~45 degrees
q := (Sqr(ppt.prev.len) + Sqr(ppt.len) - DistanceSqrd(ppt.prev.pt, ppt.next.pt)) /
(2 * ppt.prev.len * ppt.len); //Cosine Rule.
result := (1 - abs(q)) > 0.3;
end
else if ((TurnsLeft(ppt.prev.prev.pt, ppt.prev.pt, ppt.pt) =
TurnsRight(ppt.prev.pt, ppt.pt, ppt.next.pt)) and
(ppt.prev.len > compareLen) and (ppt.len > compareLen)) then
begin
//we'll also hard break whenever there's a significant inflection point
result := true;
end else
begin
//Finally, we'll also force a 'hard' break when there's a significant bend.
//Again uses the Cosine Rule.
q :=(Sqr(ppt.prev.len) + Sqr(ppt.len) -
DistanceSqrd(ppt.prev.pt, ppt.next.pt)) / (2 * ppt.prev.len * ppt.len);
Result := (q > -0.2); //ie more than 90%
end;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.FitCurve(const path: TPathD;
closed: Boolean; tolerance: double; minSegLength: double): TPathD;
var
i, highI: integer;
d: double;
p, p2, pEnd: PPt;
begin
//tolerance: specifies the maximum allowed variance between the existing
//vertices and the new Bezier curves. More tolerance will produce
//fewer Beziers and simpler paths, but at the cost of less precison.
tolSqrd := Sqr(Max(1, Min(10, tolerance))); //range 1..10
//minSegLength: Typically when vectorizing raster images, the produced
//vector paths will have many series of axis aligned segments that trace
//pixel boundaries. These paths will also contain many 1 unit segments at
//right angles to adjacent segments. Importantly, these very short segments
//will cause artifacts in the solution unless they are trimmed.
highI := High(path);
if closed then
while (highI > 0) and (Distance(path[highI], path[0]) < minSegLength) do
dec(highI);
p := AddPt(path[0]);
for i := 1 to highI do
begin
d := Distance(p.pt, path[i]);
//skip line segments with lengths less than 'minSegLength'
if d < minSegLength then Continue;
p := AddPt(path[i]);
p.prev.len := d;
p.prev.vec := SubVecs(p.pt, p.prev.pt);
end;
p.len := Distance(ppts.pt, p.pt);
p.vec := SubVecs(p.next.pt, p.pt);
p := ppts;
if (p.next = p) or (closed and (p.next = p.prev)) then
begin
Clear;
result := nil;
Exit;
end;
//for closed paths, find a good starting point
if closed then
begin
repeat
if HardBreakCheck(p, tolerance) then break;
p := p.next;
until p = ppts;
pEnd := p;
end else
pEnd := ppts.prev;
p2 := p.next;
repeat
if HardBreakCheck(p2, tolerance) then
begin
FitCubic(p, p2, ComputeLeftTangent(p), ComputeRightTangent(p2));
p := p2;
end;
p2 := p2.next;
until (p2 = pEnd);
FitCubic(p, p2, ComputeLeftTangent(p), ComputeRightTangent(p2));
Result := solution;
Clear;
end;
//------------------------------------------------------------------------------
procedure TFitCurveContainer.AppendSolution(const bezier: TPathD);
var
i, len: integer;
begin
len := Length(solution);
if len > 0 then
begin
SetLength(solution, len + 3);
for i := 0 to 2 do
solution[len +i] := bezier[i +1];
end else
solution := bezier;
end;
//------------------------------------------------------------------------------
function CurveFit(const path: TPathD; closed: Boolean;
tolerance: double; minSegLength: double): TPathD;
var
paths, solution: TPathsD;
begin
SetLength(paths, 1);
paths[0] := path;
solution := CurveFit(paths, closed, tolerance, minSegLength);
if solution <> nil then
Result := solution[0];
end;
//------------------------------------------------------------------------------
function CurveFit(const paths: TPathsD; closed: Boolean;
tolerance: double; minSegLength: double): TPathsD;
var
i,j, len: integer;
begin
j := 0;
len := Length(paths);
SetLength(Result, len);
with TFitCurveContainer.Create do
try
for i := 0 to len -1 do
if (paths[i] <> nil) and (Abs(Area(paths[i])) > Sqr(tolerance)) then
begin
Result[j] := FitCurve(paths[i], closed, tolerance, minSegLength);
inc(j);
end;
finally
Free;
end;
SetLength(Result, j);
end;
//------------------------------------------------------------------------------
end.
doublecmd-1.1.22/components/Image32/source/Img32.Fmt.SVG.pas 0000644 0001750 0000144 00000033550 14743153644 022241 0 ustar alexx users unit Img32.Fmt.SVG;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.3.1 *
* Date : 5 October 2022 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2022 *
* Purpose : SVG file format extension for TImage32 *
* License : http://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
uses
{$IFDEF MSWINDOWS} Windows, {$ENDIF} SysUtils, Classes, Math,
{$IFDEF XPLAT_GENERICS} Generics.Collections, Generics.Defaults, {$ENDIF}
Img32, Img32.Vector, Img32.SVG.Reader;
type
TImageFormat_SVG = class(TImageFormat)
public
class function IsValidImageStream(stream: TStream): Boolean; override;
function LoadFromStream(stream: TStream; img32: TImage32): Boolean; override;
procedure SaveToStream(stream: TStream; img32: TImage32); override;
class function CanCopyToClipboard: Boolean; override;
class function CopyToClipboard(img32: TImage32): Boolean; override;
class function CanPasteFromClipboard: Boolean; override;
class function PasteFromClipboard(img32: TImage32): Boolean; override;
end;
TSvgListObject = class
xml : string;
name : string;
end;
TSvgImageList32 = class(TInterfacedObj, INotifySender)
private
fReader : TSvgReader;
{$IFDEF XPLAT_GENERICS}
fList : TList;
{$ELSE}
fList : TList;
{$ENDIF}
fDefWidth : integer;
fDefHeight : integer;
fRecipientList : TRecipients;
fUpdateCnt : integer;
{$IFDEF MSWINDOWS}
fResName : string;
procedure SetResName(const resName: string);
{$ENDIF}
procedure SetDefWidth(value: integer);
procedure SetDefHeight(value: integer);
protected
procedure Changed; virtual;
procedure BeginUpdate;
procedure EndUpdate;
procedure NotifyRecipients(notifyFlag: TImg32Notification);
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function Count: integer;
function Find(const aName: string): integer;
procedure AddRecipient(recipient: INotifyRecipient);
procedure DeleteRecipient(recipient: INotifyRecipient);
function CreateImage(index: integer): TImage32;
procedure GetImage(index: integer; image: TImage32); overload;
procedure GetImage(index: integer; image: TImage32; out aName: string); overload;
procedure Add(const aName, xml: string);
procedure AddFromFile(const aName, filename: string);
procedure AddFromResource(const aName, resName: string; resType: PChar);
procedure Insert(index: integer; const name, xml: string);
procedure Move(currentIndex, newIndex: integer);
procedure Delete(index: integer);
property DefaultWidth: integer read fDefWidth write SetDefWidth;
property DefaultHeight: integer read fDefHeight write SetDefHeight;
{$IFDEF MSWINDOWS}
property ResourceName: string read fResName write SetResName;
{$ENDIF}
end;
var
defaultSvgWidth: integer = 800;
defaultSvgHeight: integer = 600;
implementation
//------------------------------------------------------------------------------
// Three routines used to enumerate a resource type
//------------------------------------------------------------------------------
function Is_IntResource(lpszType: PChar): Boolean;
begin
Result := NativeUInt(lpszType) shr 16 = 0;
end;
//------------------------------------------------------------------------------
function ResourceNameToString(lpszName: PChar): string;
begin
if Is_IntResource(lpszName) then
Result := '#' + IntToStr(NativeUInt(lpszName)) else
Result := lpszName;
end;
//------------------------------------------------------------------------------
function EnumResNameProc(hModule: HMODULE; lpszType, lpszName: PChar;
lParam: NativeInt): Boolean; stdcall;
var
n: string;
begin
n:= ResourceNameToString(lpszName);
TSvgImageList32(lParam).AddFromResource(n, n, lpszType);
Result := true;
end;
//------------------------------------------------------------------------------
// TSvgImageList32
//------------------------------------------------------------------------------
constructor TSvgImageList32.Create;
begin
fReader := TSvgReader.Create;
{$IFDEF XPLAT_GENERICS}
fList := TList.Create;
{$ELSE}
fList := TList.Create;
{$ENDIF}
end;
//------------------------------------------------------------------------------
destructor TSvgImageList32.Destroy;
begin
NotifyRecipients(inDestroy);
Clear;
fList.Free;
fReader.Free;
inherited;
end;
//------------------------------------------------------------------------------
{$IFDEF MSWINDOWS}
procedure TSvgImageList32.SetResName(const resName: string);
begin
if fResName = resName then Exit;
fResName := resName;
BeginUpdate;
try
Clear;
EnumResourceNames(HInstance, PChar(resName), @EnumResNameProc, lParam(self));
finally
EndUpdate;
end;
end;
//------------------------------------------------------------------------------
{$ENDIF}
function TSvgImageList32.Count: integer;
begin
result := fList.Count;
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.Clear;
var
i: integer;
begin
for i := 0 to fList.Count -1 do
TSvgListObject(fList[i]).Free;
fList.Clear;
Changed;
end;
//------------------------------------------------------------------------------
function TSvgImageList32.Find(const aName: string): integer;
var
i: integer;
begin
for i := 0 to fList.Count -1 do
with TSvgListObject(fList[i]) do
if SameText(name, aName) then
begin
Result := i;
Exit;
end;
Result := -1;
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.GetImage(index: integer; image: TImage32; out aName: string);
begin
if not Assigned(image) or (index < 0) or (index >= count) then Exit;
if image.IsEmpty then
image.SetSize(fDefWidth, fDefHeight);
with TSvgListObject(fList[index]) do
begin
fReader.LoadFromString(xml);
aName := name;
end;
fReader.DrawImage(image, true);
end;
//------------------------------------------------------------------------------
function TSvgImageList32.CreateImage(index: integer): TImage32;
begin
Result := TImage32.Create(DefaultWidth, DefaultHeight);
GetImage(index, Result);
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.GetImage(index: integer; image: TImage32);
var
dummy: string;
begin
GetImage(index, image, dummy);
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.Add(const aName, xml: string);
begin
Insert(count, aName, xml);
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.AddFromFile(const aName, filename: string);
begin
if not FileExists(filename) then Exit;
with TStringList.Create do
try
LoadFromFile(filename);
Self.Insert(Self.Count, aName, Text);
finally
Free;
end;
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.AddFromResource(const aName, resName: string; resType: PChar);
var
rs: TResourceStream;
ansi: AnsiString;
begin
rs := TResourceStream.Create(hInstance, resName, resType);
try
SetLength(ansi, rs.Size);
rs.Read(ansi[1], rs.Size);
Self.Insert(Self.Count, aName, string(ansi));
finally
rs.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.Insert(index: integer; const name, xml: string);
var
lo: TSvgListObject;
begin
if index < 0 then index := 0
else if index > Count then index := Count;
lo := TSvgListObject.Create;
lo.name := name;
lo.xml := xml;
fList.Insert(index, lo);
Changed;
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.Move(currentIndex, newIndex: integer);
begin
fList.Move(currentIndex, newIndex);
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.Delete(index: integer);
begin
TSvgListObject(fList[index]).Free;
fList.Delete(index);
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.BeginUpdate;
begin
inc(fUpdateCnt);
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.EndUpdate;
begin
dec(fUpdateCnt);
if fUpdateCnt = 0 then Changed;
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.Changed;
begin
if (fUpdateCnt = 0) then
NotifyRecipients(inStateChange);
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.SetDefWidth(value: integer);
begin
if fDefWidth = value then Exit;
fDefWidth := value;
Changed;
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.SetDefHeight(value: integer);
begin
if fDefHeight = value then Exit;
fDefHeight := value;
Changed;
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.AddRecipient(recipient: INotifyRecipient);
var
len: integer;
begin
len := Length(fRecipientList);
SetLength(fRecipientList, len+1);
fRecipientList[len] := Recipient;
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.DeleteRecipient(recipient: INotifyRecipient);
var
i, highI: integer;
begin
highI := High(fRecipientList);
i := highI;
while (i >= 0) and (fRecipientList[i] <> Recipient) do dec(i);
if i < 0 then Exit;
if i < highI then
System.Move(fRecipientList[i+1], fRecipientList[i],
(highI - i) * SizeOf(INotifyRecipient));
SetLength(fRecipientList, highI);
end;
//------------------------------------------------------------------------------
procedure TSvgImageList32.NotifyRecipients(notifyFlag: TImg32Notification);
var
i: integer;
begin
if fUpdateCnt > 0 then Exit;
for i := High(fRecipientList) downto 0 do
try
//when destroying in a finalization section
//it's possible for recipients to have been destroyed
//without their destructors being called.
fRecipientList[i].ReceiveNotification(self, notifyFlag);
except
end;
end;
//------------------------------------------------------------------------------
// Loading (reading) SVG images from file ...
//------------------------------------------------------------------------------
function TImageFormat_SVG.LoadFromStream(stream: TStream; img32: TImage32): Boolean;
var
r: TRectWH;
w,h, sx,sy: double;
begin
with TSvgReader.Create do
try
Result := LoadFromStream(stream);
if not Result then Exit;
r := GetViewbox(img32.Width, img32.Height);
img32.BeginUpdate;
try
if img32.IsEmpty and not r.IsEmpty then
img32.SetSize(Round(r.Width), Round(r.Height))
else if not r.IsEmpty then
begin
//then scale the SVG to fit image
w := r.Width;
h := r.Height;
sx := img32.Width / w;
sy := img32.Height / h;
if sy < sx then sx := sy;
if not(SameValue(sx, 1, 0.00001)) then
begin
w := w * sx;
h := h * sx;
end;
img32.SetSize(Round(w), Round(h));
end
else
img32.SetSize(defaultSvgWidth, defaultSvgHeight);
//draw the SVG image to fit inside the canvas
DrawImage(img32, True);
finally
img32.EndUpdate;
end;
finally
Free;
end;
end;
//------------------------------------------------------------------------------
// Saving (writing) SVG images to file (not currently implemented) ...
//------------------------------------------------------------------------------
class function TImageFormat_SVG.IsValidImageStream(stream: TStream): Boolean;
var
i, savedPos, len: integer;
buff: array [1..1024] of AnsiChar;
begin
Result := false;
savedPos := stream.Position;
len := Min(1024, stream.Size - savedPos);
stream.Read(buff[1], len);
stream.Position := savedPos;
for i := 1 to len -4 do
begin
if buff[i] < #9 then Exit
else if (buff[i] = '<') and
(buff[i +1] = 's') and
(buff[i +2] = 'v') and
(buff[i +3] = 'g') then
begin
Result := true;
break;
end;
end;
end;
//------------------------------------------------------------------------------
procedure TImageFormat_SVG.SaveToStream(stream: TStream; img32: TImage32);
begin
//not enabled
end;
//------------------------------------------------------------------------------
class function TImageFormat_SVG.CanCopyToClipboard: Boolean;
begin
Result := false;
end;
//------------------------------------------------------------------------------
class function TImageFormat_SVG.CopyToClipboard(img32: TImage32): Boolean;
begin
Result := false;
end;
//------------------------------------------------------------------------------
class function TImageFormat_SVG.CanPasteFromClipboard: Boolean;
begin
Result := false;
end;
//------------------------------------------------------------------------------
class function TImageFormat_SVG.PasteFromClipboard(img32: TImage32): Boolean;
begin
Result := false;
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
initialization
TImage32.RegisterImageFormatClass('SVG', TImageFormat_SVG, cpLow);
end.
doublecmd-1.1.22/components/Image32/source/Img32.Resamplers.pas 0000644 0001750 0000144 00000027474 14743153644 023202 0 ustar alexx users unit Img32.Resamplers;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.3 *
* Date : 27 September 2022 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2021 *
* Purpose : For image transformations (scaling, rotating etc.) *
* License : http://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
uses
SysUtils, Classes, Img32;
//BoxDownSampling: As the name implies, this routine is only intended for
//image down-sampling (ie when shrinking images) where it generally performs
//better than other resamplers which tend to lose too much detail. However,
//because this routine is inferior to other resamplers when performing other
//transformations (ie when enlarging, rotating, and skewing images), it's not
//intended as a general purpose resampler.
procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer);
(* The following functions are registered in the initialization section below
function NearestResampler(img: TImage32; x256, y256: Integer): TColor32;
function BilinearResample(img: TImage32; x256, y256: Integer): TColor32;
function BicubicResample(img: TImage32; x256, y256: Integer): TColor32;
*)
implementation
uses
Img32.Transform;
//------------------------------------------------------------------------------
// NearestNeighbor resampler
//------------------------------------------------------------------------------
function NearestResampler(img: TImage32; x256, y256: Integer): TColor32;
begin
if (x256 < -$7f) then
begin
Result := clNone32;
Exit;
end;
if (y256 < -$7f) then
begin
Result := clNone32;
Exit;
end;
if (x256 and $FF > $7F) then inc(x256, $100);
x256 := x256 shr 8;
if y256 and $FF > $7F then inc(y256, $100);
y256 := y256 shr 8;
if (x256 < 0) or (x256 >= img.Width) or
(y256 < 0) or (y256 >= img.Height) then
Result := clNone32 else
Result := img.Pixels[y256 * img.Width + x256];
end;
//------------------------------------------------------------------------------
// BiLinear resampler
//------------------------------------------------------------------------------
function BilinearResample(img: TImage32; x256, y256: Integer): TColor32;
var
xi,yi, weight: Integer;
iw, ih: integer;
pixels: TArrayOfColor32;
color: TWeightedColor;
xf, yf: cardinal;
begin
iw := img.Width;
ih := img.Height;
pixels := img.Pixels;
if (x256 <= -$100) or (x256 >= iw *$100) or
(y256 <= -$100) or (y256 >= ih *$100) then
begin
result := clNone32;
Exit;
end;
if x256 < 0 then xi := -1
else xi := x256 shr 8;
if y256 < 0 then yi := -1
else yi := y256 shr 8;
xf := x256 and $FF;
yf := y256 and $FF;
color.Reset;
weight := (($100 - xf) * ($100 - yf)) shr 8; //top-left
if (xi < 0) or (yi < 0) then
color.AddWeight(weight) else
color.Add(pixels[xi + yi * iw], weight);
weight := (xf * ($100 - yf)) shr 8; //top-right
if ((xi+1) >= iw) or (yi < 0) then
color.AddWeight(weight) else
color.Add(pixels[(xi+1) + yi * iw], weight);
weight := (($100 - xf) * yf) shr 8; //bottom-left
if (xi < 0) or ((yi+1) >= ih) then
color.AddWeight(weight) else
color.Add(pixels[(xi) + (yi+1) * iw], weight);
weight := (xf * yf) shr 8; //bottom-right
if (xi + 1 >= iw) or (yi + 1 >= ih) then
color.AddWeight(weight) else
color.Add(pixels[(xi+1) + (yi+1) * iw], weight);
Result := color.Color;
end;
//------------------------------------------------------------------------------
// BiCubic resampler
//------------------------------------------------------------------------------
type
TBiCubicEdgeAdjust = (eaNone, eaOne, eaTwo, eaThree, eaFour);
var
byteFrac: array [0..255] of double;
byteFracSq: array [0..255] of double;
byteFracCubed: array [0..255] of double;
//------------------------------------------------------------------------------
function CubicHermite(aclr: PColor32; t: Byte; bce: TBiCubicEdgeAdjust): TColor32;
var
a,b,c,d: PARGB;
q: TARGB;
aa, bb, cc: integer;
t1, t2, t3: double;
res: TARGB absolute Result;
const
clTrans: TColor32 = clNone32;
begin
case bce of
eaOne:
begin
a := @clTrans;
b := @clTrans;
c := PARGB(aclr);
Inc(aclr);
d := PARGB(aclr);
end;
eaTwo:
begin
a := PARGB(aclr);
b := a;
Inc(aclr);
c := PARGB(aclr);
Inc(aclr);
d := PARGB(aclr);
end;
eaThree:
begin
a := PARGB(aclr);
Inc(aclr);
b := PARGB(aclr);
Inc(aclr);
c := PARGB(aclr);
d := c;
end;
eaFour:
begin
a := PARGB(aclr);
Inc(aclr);
b := PARGB(aclr);
c := @clTrans;
d := @clTrans;
end;
else
begin
a := PARGB(aclr);
Inc(aclr);
b := PARGB(aclr);
Inc(aclr);
c := PARGB(aclr);
Inc(aclr);
d := PARGB(aclr);
end;
end;
if (b.A = 0) and (c.A = 0) then
begin
result := clNone32;
Exit;
end
else if b.A = 0 then
begin
q := c^;
q.A := 0;
b := @q;
end;
if c.A = 0 then
begin
q := b^;
q.A := 0;
c := @q;
end;
t1 := byteFrac[t];
t2 := byteFracSq[t];
t3 := byteFracCubed[t];
aa := Integer(-a.A + 3*b.A - 3*c.A + d.A) div 2;
bb := Integer(2*a.A - 5*b.A + 4*c.A - d.A) div 2;
cc := Integer(-a.A + c.A) div 2;
Res.A := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.A);
aa := Integer(-a.R + 3*b.R - 3*c.R + d.R) div 2;
bb := Integer(2*a.R - 5*b.R + 4*c.R - d.R) div 2;
cc := Integer(-a.R + c.R) div 2;
Res.R := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.R);
aa := Integer(-a.G + 3*b.G - 3*c.G + d.G) div 2;
bb := Integer(2*a.G - 5*b.G + 4*c.G - d.G) div 2;
cc := Integer(-a.G + c.G) div 2;
Res.G := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.G);
aa := Integer(-a.B + 3*b.B - 3*c.B + d.B) div 2;
bb := Integer(2*a.B - 5*b.B + 4*c.B - d.B) div 2;
cc := Integer(-a.B + c.B) div 2;
Res.B := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.B);
end;
//------------------------------------------------------------------------------
function BicubicResample(img: TImage32; x256, y256: Integer): TColor32;
var
i, dx,dy, pi, iw, w,h: Integer;
c: array[0..3] of TColor32;
x, y: Integer;
bceX, bceY: TBiCubicEdgeAdjust;
begin
Result := clNone32;
iw := img.Width;
w := iw -1;
h := img.Height -1;
x := Abs(x256) shr 8;
y := Abs(y256) shr 8;
if (x256 < -$FF) or (x > w) or (y256 < -$FF) or (y > h) then Exit;
if (x256 < 0) then bceX := eaOne
else if (x = 0) then bceX := eaTwo
else if (x256 > w shl 8) then bceX := eaFour
else if (x256 > (w -1) shl 8) then bceX := eaThree
else bceX := eaNone;
if (bceX = eaOne) or (bceX = eaTwo) then dx := 1
else dx := 0;
if (y256 < 0) then bceY := eaOne
else if y = 0 then bceY := eaTwo
else if y = h -1 then bceY := eaThree
else if y = h then bceY := eaFour
else bceY := eaNone;
if (bceY = eaOne) or (bceY = eaTwo) then dy := 1
else dy := 0;
pi := (y -1 +dy) * iw + (x -1 + dx);
if bceY = eaFour then dx := 2
else if bceY = eaThree then dx := 1
else dx := 0;
for i := dy to 3 -dx do
begin
c[i] := CubicHermite(@img.Pixels[pi], x256 and $FF, bceX);
inc(pi, iw);
end;
Result := CubicHermite(@c[dy], y256 and $FF, bceY);
end;
//------------------------------------------------------------------------------
// BoxDownSampling and related functions
//------------------------------------------------------------------------------
function GetWeightedColor(const srcBits: TArrayOfColor32;
x256, y256, xx256, yy256, maxX: Integer): TColor32;
var
i, j, xi, yi, xxi, yyi, weight: Integer;
xf, yf, xxf, yyf: cardinal;
color: TWeightedColor;
begin
//This function performs 'box sampling' and differs from GetWeightedPixel
//(bilinear resampling) in one important aspect - it accommodates weighting
//any number of pixels (rather than just adjacent pixels) and this produces
//better image quality when significantly downsizing.
//Note: there's no range checking here, so the precondition is that the
//supplied boundary values are within the bounds of the srcBits array.
color.Reset;
xi := x256 shr 8; xf := x256 and $FF;
yi := y256 shr 8; yf := y256 and $FF;
xxi := xx256 shr 8; xxf := xx256 and $FF;
yyi := yy256 shr 8; yyf := yy256 and $FF;
//1. average the corners ...
weight := (($100 - xf) * ($100 - yf)) shr 8;
color.Add(srcBits[xi + yi * maxX], weight);
weight := (xxf * ($100 - yf)) shr 8;
if (weight <> 0) then color.Add(srcBits[xxi + yi * maxX], weight);
weight := (($100 - xf) * yyf) shr 8;
if (weight <> 0) then color.Add(srcBits[xi + yyi * maxX], weight);
weight := (xxf * yyf) shr 8;
if (weight <> 0) then color.Add(srcBits[xxi + yyi * maxX], weight);
//2. average the edges
if (yi +1 < yyi) then
begin
xf := $100 - xf;
for i := yi + 1 to yyi - 1 do
color.Add(srcBits[xi + i * maxX], xf);
if (xxf <> 0) then
for i := yi + 1 to yyi - 1 do
color.Add(srcBits[xxi + i * maxX], xxf);
end;
if (xi + 1 < xxi) then
begin
yf := $100 - yf;
for i := xi + 1 to xxi - 1 do
color.Add(srcBits[i + yi * maxX], yf);
if (yyf <> 0) then
for i := xi + 1 to xxi - 1 do
color.Add(srcBits[i + yyi * maxX], yyf);
end;
//3. average the non-fractional pixel 'internals' ...
for i := xi + 1 to xxi - 1 do
for j := yi + 1 to yyi - 1 do
color.Add(srcBits[i + j * maxX], $100);
//4. finally get the weighted color ...
if color.AddCount = 0 then
Result := srcBits[xi + yi * maxX] else
Result := color.Color;
end;
//------------------------------------------------------------------------------
procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer);
var
x,y, x256,y256,xx256,yy256: Integer;
sx,sy: double;
tmp: TArrayOfColor32;
pc: PColor32;
scaledX: array of Integer;
begin
sx := Image.Width/newWidth * 256;
sy := Image.Height/newHeight * 256;
SetLength(tmp, newWidth * newHeight);
SetLength(scaledX, newWidth +1); //+1 for fractional overrun
for x := 0 to newWidth -1 do
scaledX[x] := Round((x+1) * sx);
y256 := 0;
pc := @tmp[0];
for y := 0 to newHeight - 1 do
begin
x256 := 0;
yy256 := Round((y+1) * sy);
for x := 0 to newWidth - 1 do
begin
xx256 := scaledX[x];
pc^ := GetWeightedColor(Image.Pixels,
x256, y256, xx256, yy256, Image.Width);
x256 := xx256;
inc(pc);
end;
y256 := yy256;
end;
Image.BeginUpdate;
Image.SetSize(newWidth, newHeight);
Move(tmp[0], Image.Pixels[0], newWidth * newHeight * SizeOf(TColor32));
Image.EndUpdate;
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
procedure InitByteExponents;
var
i: integer;
const
inv255 : double = 1/255;
inv255sqrd : double = 1/(255*255);
inv255cubed: double = 1/(255*255*255);
begin
for i := 0 to 255 do
begin
byteFrac[i] := i *inv255;
byteFracSq[i] := i*i *inv255sqrd;
byteFracCubed[i] := i*i*i *inv255cubed;
end;
end;
//------------------------------------------------------------------------------
initialization
InitByteExponents;
rNearestResampler := RegisterResampler(NearestResampler, 'NearestNeighbor');
rBilinearResampler := RegisterResampler(BilinearResample, 'Bilinear');
rBicubicResampler := RegisterResampler(BicubicResample, 'HermiteBicubic');
DefaultResampler := rBilinearResampler;
end.
doublecmd-1.1.22/components/Image32/source/Img32.SVG.Core.pas 0000644 0001750 0000144 00000172217 14743153644 022407 0 ustar alexx users unit Img32.SVG.Core;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.3 *
* Date : 27 September 2022 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2022 *
* *
* Purpose : Essential structures and functions to read SVG files *
* *
* License : Use, modification & distribution is subject to *
* Boost Software License Ver 1 *
* http://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
uses
SysUtils, Classes, Types, Math,
{$IFDEF XPLAT_GENERICS} Generics.Collections, Generics.Defaults,{$ENDIF}
Img32, Img32.Vector, Img32.Text, Img32.Transform;
{$IFDEF ZEROBASEDSTR}
{$ZEROBASEDSTRINGS OFF}
{$ENDIF}
type
TSvgEncoding = (eUnknown, eUtf8, eUnicodeLE, eUnicodeBE);
TUnitType = (utUnknown, utNumber, utPercent, utEm, utEx, utPixel,
utCm, utMm, utInch, utPt, utPica, utDegree, utRadian);
//////////////////////////////////////////////////////////////////////
// TValue - Structure to store numerics with measurement units.
// See https://www.w3.org/TR/SVG/types.html#InterfaceSVGLength
// and https://www.w3.org/TR/SVG/types.html#InterfaceSVGAngle
//////////////////////////////////////////////////////////////////////
//Unfortunately unit-less values can exhibit ambiguity, especially when their
//values are small (eg < 1.0). These values can be either absolute values or
//relative values (ie relative to the supplied dimension size).
//The 'assumeRelValBelow' parameter (see below) attempts to address this
//ambiguity, such that unit-less values will be assumed to be 'relative' when
//'rawVal' is less than the supplied 'assumeRelValBelow' value.
TValue = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF}
rawVal : double;
unitType : TUnitType;
procedure Init;
procedure SetValue(val: double; unitTyp: TUnitType = utNumber);
function GetValue(relSize: double; assumeRelValBelow: Double): double;
function GetValueXY(const relSize: TRectD; assumeRelValBelow: Double): double;
function IsValid: Boolean;
function IsRelativeValue(assumeRelValBelow: double): Boolean;
{$IFDEF INLINE} inline; {$ENDIF}
function HasFontUnits: Boolean;
function HasAngleUnits: Boolean;
end;
TValuePt = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF}
X, Y : TValue;
procedure Init;
function GetPoint(const relSize: double; assumeRelValBelow: Double): TPointD; overload;
function GetPoint(const relSize: TRectD; assumeRelValBelow: Double): TPointD; overload;
function IsValid: Boolean;
end;
TValueRecWH = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF}
left : TValue;
top : TValue;
width : TValue;
height : TValue;
procedure Init;
function GetRectD(const relSize: TRectD; assumeRelValBelow: Double): TRectD; overload;
function GetRectD(relSize: double; assumeRelValBelow: Double): TRectD; overload;
function GetRectWH(const relSize: TRectD; assumeRelValBelow: Double): TRectWH;
function IsValid: Boolean;
function IsEmpty: Boolean;
end;
{$IFNDEF UNICODE}
UTF8Char = Char;
PUTF8Char = PChar;
{$ELSE}
{$IF COMPILERVERSION < 31}
UTF8Char = AnsiChar;
PUTF8Char = PAnsiChar;
{$IFEND}
{$ENDIF}
TSvgItalicSyle = (sfsUndefined, sfsNone, sfsItalic);
TFontDecoration = (fdUndefined, fdNone, fdUnderline, fdStrikeThrough);
TSvgTextAlign = (staUndefined, staLeft, staCenter, staRight);
TSVGFontInfo = record
family : TTtfFontFamily;
size : double;
spacing : double;
textLength : double;
italic : TSvgItalicSyle;
weight : Integer;
align : TSvgTextAlign;
decoration : TFontDecoration;
baseShift : TValue;
end;
//////////////////////////////////////////////////////////////////////
// TClassStylesList: custom TStringList that stores ansistring objects
//////////////////////////////////////////////////////////////////////
PAnsStringiRec = ^TAnsiStringRec; //used internally by TClassStylesList
TAnsiStringRec = record
ansi : UTF8String;
end;
TClassStylesList = class
private
fList : TStringList;
public
constructor Create;
destructor Destroy; override;
function AddAppendStyle(const classname: string; const ansi: UTF8String): integer;
function GetStyle(const classname: UTF8String): UTF8String;
procedure Clear;
end;
//////////////////////////////////////////////////////////////////////
// TSvgParser and associated classes - a simple parser for SVG xml
//////////////////////////////////////////////////////////////////////
PSvgAttrib = ^TSvgAttrib; //element attribute
TSvgAttrib = record
hash : Cardinal; //hashed name
name : UTF8String;
value : UTF8String;
end;
TSvgParser = class;
TXmlEl = class //base element class
private
{$IFDEF XPLAT_GENERICS}
attribs : TList ;
{$ELSE}
attribs : TList;
{$ENDIF}
function GetAttrib(index: integer): PSvgAttrib;
function GetAttribCount: integer;
public
{$IFDEF XPLAT_GENERICS}
childs : TList;
{$ELSE}
childs : TList;
{$ENDIF}
name : UTF8String;
owner : TSvgParser;
hash : Cardinal;
text : UTF8String;
selfClosed : Boolean;
constructor Create(owner: TSvgParser); virtual;
destructor Destroy; override;
procedure Clear; virtual;
function ParseHeader(var c: PUTF8Char; endC: PUTF8Char): Boolean; virtual;
function ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean; virtual;
function ParseAttribName(var c: PUTF8Char; endC: PUTF8Char; attrib: PSvgAttrib): Boolean;
function ParseAttribValue(var c: PUTF8Char; endC: PUTF8Char; attrib: PSvgAttrib): Boolean;
function ParseAttributes(var c: PUTF8Char; endC: PUTF8Char): Boolean; virtual;
procedure ParseStyleAttribute(const style: UTF8String);
property Attrib[index: integer]: PSvgAttrib read GetAttrib;
property AttribCount: integer read GetAttribCount;
end;
TDocTypeEl = class(TXmlEl)
private
procedure SkipWord(var c, endC: PUTF8Char);
function ParseEntities(var c, endC: PUTF8Char): Boolean;
public
function ParseAttributes(var c: PUTF8Char; endC: PUTF8Char): Boolean; override;
end;
TSvgTreeEl = class(TXmlEl)
public
constructor Create(owner: TSvgParser); override;
procedure Clear; override;
function ParseHeader(var c: PUTF8Char; endC: PUTF8Char): Boolean; override;
end;
TSvgParser = class
private
svgStream : TMemoryStream;
procedure ParseStream;
public
classStyles :TClassStylesList;
xmlHeader : TXmlEl;
docType : TDocTypeEl;
svgTree : TSvgTreeEl;
constructor Create;
destructor Destroy; override;
procedure Clear;
function FindEntity(hash: Cardinal): PSvgAttrib;
function LoadFromFile(const filename: string): Boolean;
function LoadFromStream(stream: TStream): Boolean;
function LoadFromString(const str: string): Boolean;
end;
//////////////////////////////////////////////////////////////////////
// Miscellaneous SVG functions
//////////////////////////////////////////////////////////////////////
//general parsing functions //////////////////////////////////////////
function ParseNextWord(var c: PUTF8Char; endC: PUTF8Char;
out word: UTF8String): Boolean;
function ParseNextWordEx(var c: PUTF8Char; endC: PUTF8Char;
out word: UTF8String): Boolean;
function ParseNextNum(var c: PUTF8Char; endC: PUTF8Char;
skipComma: Boolean; out val: double): Boolean;
function ParseNextNumEx(var c: PUTF8Char; endC: PUTF8Char; skipComma: Boolean;
out val: double; out unitType: TUnitType): Boolean;
function GetHash(const name: UTF8String): cardinal;
function GetHashCaseSensitive(name: PUTF8Char; nameLen: integer): cardinal;
function ExtractRef(const href: UTF8String): UTF8String;
function IsNumPending(var c: PUTF8Char;
endC: PUTF8Char; ignoreComma: Boolean): Boolean;
function UTF8StringToColor32(const value: UTF8String; var color: TColor32): Boolean;
function MakeDashArray(const dblArray: TArrayOfDouble; scale: double): TArrayOfInteger;
function Match(c: PUTF8Char; const compare: UTF8String): Boolean; overload;
function Match(const compare1, compare2: UTF8String): Boolean; overload;
function ToUTF8String(var c: PUTF8Char; endC: PUTF8Char): UTF8String;
//special parsing functions //////////////////////////////////////////
procedure ParseStyleElementContent(const value: UTF8String; stylesList: TClassStylesList);
function ParseTransform(const transform: UTF8String): TMatrixD;
procedure GetSvgFontInfo(const value: UTF8String; var fontInfo: TSVGFontInfo);
function HtmlDecode(const html: UTF8String): UTF8String;
function GetXmlEncoding(memory: Pointer; len: integer): TSvgEncoding;
function ClampRange(val, min, max: double): double;
function SkipBlanks(var c: PUTF8Char; endC: PUTF8Char): Boolean;
function SkipBlanksAndComma(var current: PUTF8Char; currentEnd: PUTF8Char): Boolean;
type
TSetOfUTF8Char = set of UTF8Char;
UTF8Strings = array of UTF8String;
function CharInSet(chr: UTF8Char; chrs: TSetOfUTF8Char): Boolean;
const
clInvalid = $00010001;
clCurrent = $00010002;
sqrt2 = 1.4142135623731;
quote = '''';
dquote = '"';
space = #32;
SvgDecimalSeparator = '.'; //do not localize
{$I Img32.SVG.HashConsts.inc}
var
LowerCaseTable : array[#0..#255] of UTF8Char;
ColorConstList : TStringList;
implementation
type
TColorConst = record
ColorName : string;
ColorValue: Cardinal;
end;
TColorObj = class
cc: TColorConst;
end;
const
buffSize = 8;
//include hashed html entity constants
{$I Img32.SVG.HtmlHashConsts.inc}
//------------------------------------------------------------------------------
// Miscellaneous functions ...
//------------------------------------------------------------------------------
function ClampRange(val, min, max: double): double;
{$IFDEF INLINE} inline; {$ENDIF}
begin
if val <= min then Result := min
else if val >= max then Result := max
else Result := val;
end;
//------------------------------------------------------------------------------
function CharInSet(chr: UTF8Char; chrs: TSetOfUTF8Char): Boolean;
begin
Result := chr in chrs;
end;
//------------------------------------------------------------------------------
function Match(c: PUTF8Char; const compare: UTF8String): Boolean;
var
i: integer;
begin
Result := false;
for i := 1 to Length(compare) do
begin
if LowerCaseTable[c^] <> compare[i] then Exit;
inc(c);
end;
Result := true;
end;
//------------------------------------------------------------------------------
function Match(const compare1, compare2: UTF8String): Boolean;
var
i, len: integer;
c1, c2: PUTF8Char;
begin
Result := false;
len := Length(compare1);
if len <> Length(compare2) then Exit;
c1 := @compare1[1]; c2 := @compare2[1];
for i := 1 to len do
begin
if LowerCaseTable[c1^] <> LowerCaseTable[c2^] then Exit;
inc(c1); inc(c2);
end;
Result := true;
end;
//------------------------------------------------------------------------------
function Split(const str: UTF8String): UTF8Strings;
var
i,j,k, spcCnt, len: integer;
begin
spcCnt := 0;
i := 1;
len := Length(str);
while (len > 0) and (str[len] <= #32) do dec(len);
while (i <= len) and (str[i] <= #32) do inc(i);
for j := i + 1 to len do
if (str[j] <= #32) and (str[j -1] > #32) then inc(spcCnt);
SetLength(Result, spcCnt +1);
for k := 0 to spcCnt do
begin
j := i;
while (j <= len) and (str[j] > #32) do inc(j);
SetLength(Result[k], j -i);
Move(str[i], Result[k][1], j -i);
while (j <= len) and (str[j] <= #32) do inc(j);
i := j;
end;
end;
//------------------------------------------------------------------------------
function GetXmlEncoding(memory: Pointer; len: integer): TSvgEncoding;
var
p: PUTF8Char;
begin
Result := eUnknown;
if (len < 4) or not Assigned(memory) then Exit;
p := PUTF8Char(memory);
case p^ of
#$EF: if ((p +1)^ = #$BB) and ((p +2)^ = #$BF) then Result := eUtf8;
#$FF: if ((p +1)^ = #$FE) then Result := eUnicodeLE;
#$FE: if ((p +1)^ = #$FF) then Result := eUnicodeBE;
end;
end;
//------------------------------------------------------------------------------
function SkipBlanks(var c: PUTF8Char; endC: PUTF8Char): Boolean;
begin
while (c < endC) and (c^ <= space) do inc(c);
Result := (c < endC);
end;
//------------------------------------------------------------------------------
function SkipBlanksAndComma(var current: PUTF8Char; currentEnd: PUTF8Char): Boolean;
begin
Result := SkipBlanks(current, currentEnd);
if not Result or (current^ <> ',') then Exit;
inc(current);
Result := SkipBlanks(current, currentEnd);
end;
//------------------------------------------------------------------------------
function SkipStyleBlanks(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
inComment: Boolean;
begin
//style content may include multi-line comment blocks
inComment := false;
while (c < endC) do
begin
if inComment then
begin
if (c^ = '*') and ((c +1)^ = '/') then
begin
inComment := false;
inc(c);
end;
end
else if (c^ > space) then
begin
inComment := (c^ = '/') and ((c +1)^ = '*');
if not inComment then break;
end;
inc(c);
end;
Result := (c < endC);
end;
//------------------------------------------------------------------------------
function IsAlpha(c: UTF8Char): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
begin
Result := CharInSet(c, ['A'..'Z','a'..'z']);
end;
//------------------------------------------------------------------------------
function ParseStyleNameLen(var c: PUTF8Char; endC: PUTF8Char): integer;
var
c2: PUTF8Char;
const
validNonFirstChars = ['0'..'9','A'..'Z','a'..'z','-'];
begin
Result := 0;
//nb: style names may start with a hyphen
if (c^ = '-') then
begin
if not IsAlpha((c+1)^) then Exit;
end
else if not IsAlpha(c^) then Exit;
c2 := c; inc(c);
while (c < endC) and CharInSet(c^, validNonFirstChars) do inc(c);
Result := c - c2;
end;
//------------------------------------------------------------------------------
function ParseNextWord(var c: PUTF8Char; endC: PUTF8Char; out word: UTF8String): Boolean;
var
c2: PUTF8Char;
begin
Result := SkipBlanksAndComma(c, endC);
if not Result then Exit;
c2 := c;
while (c < endC) and
(LowerCaseTable[c^] >= 'a') and (LowerCaseTable[c^] <= 'z') do
inc(c);
word := ToUTF8String(c2, c);
end;
//------------------------------------------------------------------------------
function ParseNextWordEx(var c: PUTF8Char; endC: PUTF8Char;
out word: UTF8String): Boolean;
var
isQuoted: Boolean;
c2: PUTF8Char;
begin
Result := SkipBlanksAndComma(c, endC);
if not Result then Exit;
isQuoted := (c^) = quote;
if isQuoted then
begin
inc(c);
c2 := c;
while (c < endC) and (c^ <> quote) do inc(c);
word := ToUTF8String(c2, c);
inc(c);
end else
begin
Result := CharInSet(LowerCaseTable[c^], ['A'..'Z', 'a'..'z']);
if not Result then Exit;
c2 := c;
inc(c);
while (c < endC) and
CharInSet(LowerCaseTable[c^], ['A'..'Z', 'a'..'z', '-', '_']) do inc(c);
word := ToUTF8String(c2, c);
end;
end;
//------------------------------------------------------------------------------
function ParseNameLength(var c: PUTF8Char; endC: PUTF8Char): integer; overload;
var
c2: PUTF8Char;
const
validNonFirstChars = ['0'..'9','A'..'Z','a'..'z','_',':','-'];
begin
c2 := c;
inc(c);
while (c < endC) and CharInSet(c^, validNonFirstChars) do inc(c);
Result := c - c2;
end;
//------------------------------------------------------------------------------
{$OVERFLOWCHECKS OFF}
function GetHash(const name: UTF8String): cardinal;
var
i: integer;
c: PUTF8Char;
begin
//https://en.wikipedia.org/wiki/Jenkins_hash_function
c := PUTF8Char(name);
Result := 0;
if c = nil then Exit;
for i := 1 to Length(name) do
begin
Result := (Result + Ord(LowerCaseTable[c^]));
Result := Result + (Result shl 10);
Result := Result xor (Result shr 6);
inc(c);
end;
Result := Result + (Result shl 3);
Result := Result xor (Result shr 11);
Result := Result + (Result shl 15);
end;
{$OVERFLOWCHECKS ON}
//------------------------------------------------------------------------------
{$OVERFLOWCHECKS OFF}
function GetHashCaseSensitive(name: PUTF8Char; nameLen: integer): cardinal;
var
i: integer;
begin
Result := 0;
for i := 1 to nameLen do
begin
Result := (Result + Ord(name^));
Result := Result + (Result shl 10);
Result := Result xor (Result shr 6);
inc(name);
end;
Result := Result + (Result shl 3);
Result := Result xor (Result shr 11);
Result := Result + (Result shl 15);
end;
{$OVERFLOWCHECKS ON}
//------------------------------------------------------------------------------
function ParseNextWordHashed(var c: PUTF8Char; endC: PUTF8Char): cardinal;
var
c2: PUTF8Char;
name: UTF8String;
begin
c2 := c;
ParseNameLength(c, endC);
name := ToUTF8String(c2, c);
if name = '' then Result := 0
else Result := GetHash(name);
end;
//------------------------------------------------------------------------------
function ParseNextNumEx(var c: PUTF8Char; endC: PUTF8Char; skipComma: Boolean;
out val: double; out unitType: TUnitType): Boolean;
var
decPos,exp: integer;
isNeg, expIsNeg: Boolean;
start: PUTF8Char;
begin
Result := false;
unitType := utNumber;
//skip white space +/- single comma
if skipComma then
begin
while (c < endC) and (c^ <= space) do inc(c);
if (c^ = ',') then inc(c);
end;
while (c < endC) and (c^ <= space) do inc(c);
if (c = endC) then Exit;
decPos := -1; exp := Invalid; expIsNeg := false;
isNeg := c^ = '-';
if isNeg then inc(c);
val := 0;
start := c;
while c < endC do
begin
if Ord(c^) = Ord(SvgDecimalSeparator) then
begin
if decPos >= 0 then break;
decPos := 0;
end
else if (LowerCaseTable[c^] = 'e') and
(CharInSet((c+1)^, ['-','0'..'9'])) then
begin
if (c +1)^ = '-' then expIsNeg := true;
inc(c);
exp := 0;
end
else if (c^ < '0') or (c^ > '9') then
break
else if IsValid(exp) then
begin
exp := exp * 10 + (Ord(c^) - Ord('0'))
end else
begin
val := val *10 + Ord(c^) - Ord('0');
if decPos >= 0 then inc(decPos);
end;
inc(c);
end;
Result := c > start;
if not Result then Exit;
if decPos > 0 then val := val * Power(10, -decPos);
if isNeg then val := -val;
if IsValid(exp) then
begin
if expIsNeg then
val := val * Power(10, -exp) else
val := val * Power(10, exp);
end;
//https://oreillymedia.github.io/Using_SVG/guide/units.html
case c^ of
'%':
begin
inc(c);
unitType := utPercent;
end;
'c': //convert cm to pixels
if ((c+1)^ = 'm') then
begin
inc(c, 2);
unitType := utCm;
end;
'd': //ignore deg
if ((c+1)^ = 'e') and ((c+2)^ = 'g') then
begin
inc(c, 3);
unitType := utDegree;
end;
'e': //convert cm to pixels
if ((c+1)^ = 'm') then
begin
inc(c, 2);
unitType := utEm;
end
else if ((c+1)^ = 'x') then
begin
inc(c, 2);
unitType := utEx;
end;
'i': //convert inchs to pixels
if ((c+1)^ = 'n') then
begin
inc(c, 2);
unitType := utInch;
end;
'm': //convert mm to pixels
if ((c+1)^ = 'm') then
begin
inc(c, 2);
unitType := utMm;
end;
'p':
case (c+1)^ of
'c':
begin
inc(c, 2);
unitType := utPica;
end;
't':
begin
inc(c, 2);
unitType := utPt;
end;
'x':
begin
inc(c, 2);
unitType := utPixel;
end;
end;
'r': //convert radian angles to degrees
if Match(c, 'rad') then
begin
inc(c, 3);
unitType := utRadian;
end;
end;
end;
//------------------------------------------------------------------------------
function ParseNextNum(var c: PUTF8Char; endC: PUTF8Char;
skipComma: Boolean; out val: double): Boolean;
var
tmp: TValue;
begin
tmp.Init;
Result := ParseNextNumEx(c, endC, skipComma, tmp.rawVal, tmp.unitType);
val := tmp.GetValue(1, 1);
end;
//------------------------------------------------------------------------------
function ExtractRef(const href: UTF8String): UTF8String; {$IFDEF INLINE} inline; {$ENDIF}
var
c, c2, endC: PUTF8Char;
begin
c := PUTF8Char(href);
endC := c + Length(href);
if Match(c, 'url(') then
begin
inc(c, 4);
dec(endC); // avoid trailing ')'
end;
if c^ = '#' then inc(c);
c2 := c;
while (c < endC) and (c^ <> ')') do inc(c);
Result := ToUTF8String(c2, c);
end;
//------------------------------------------------------------------------------
function ParseNextChar(var c: PUTF8Char; endC: PUTF8Char): UTF8Char;
begin
Result := #0;
if not SkipBlanks(c, endC) then Exit;
Result := c^;
inc(c);
end;
//------------------------------------------------------------------------------
function ParseQuoteChar(var c: PUTF8Char; endC: PUTF8Char): UTF8Char;
begin
if SkipBlanks(c, endC) and (c^ in [quote, dquote]) then
begin
Result := c^;
inc(c);
end else
Result := #0;
end;
//------------------------------------------------------------------------------
function AllTrim(var name: UTF8String): Boolean;
var
i, len: integer;
begin
len := Length(name);
i := 0;
while (len > 0) and (name[1] <= space) do
begin
inc(i); dec(len);
end;
if i > 0 then Delete(name, 1, i);
Result := len > 0;
if not Result then Exit;
while name[len] <= space do dec(len);
SetLength(name, len);
end;
//------------------------------------------------------------------------------
function ToUTF8String(var c: PUTF8Char; endC: PUTF8Char): UTF8String;
var
len: integer;
begin
len := endC - c;
SetLength(Result, len);
if len = 0 then Exit;
Move(c^, Result[1], len * SizeOf(UTF8Char));
c := endC;
end;
//------------------------------------------------------------------------------
function IsKnownEntity(owner: TSvgParser;
var c: PUTF8Char; endC: PUTF8Char; out entity: PSvgAttrib): boolean;
var
c2, c3: PUTF8Char;
entityName: UTF8String;
begin
inc(c); //skip ampersand.
c2 := c; c3 := c;
ParseNameLength(c3, endC);
entityName := ToUTF8String(c2, c3);
entity := owner.FindEntity(GetHash(entityName));
Result := (c3^ = ';') and Assigned(entity);
//nb: increments 'c' only if the entity is found.
if Result then c := c3 +1 else dec(c);
end;
//------------------------------------------------------------------------------
function ParseQuotedString(var c: PUTF8Char; endC: PUTF8Char;
out quotStr: UTF8String): Boolean;
var
quote: UTF8Char;
c2: PUTF8Char;
begin
quote := c^;
inc(c);
c2 := c;
while (c < endC) and (c^ <> quote) do inc(c);
Result := (c < endC);
if not Result then Exit;
quotStr := ToUTF8String(c2, c);
inc(c);
end;
//------------------------------------------------------------------------------
function IsNumPending(var c: PUTF8Char;
endC: PUTF8Char; ignoreComma: Boolean): Boolean;
var
c2: PUTF8Char;
begin
Result := false;
//skip white space +/- single comma
if ignoreComma then
begin
while (c < endC) and (c^ <= space) do inc(c);
if (c^ = ',') then inc(c);
end;
while (c < endC) and (c^ <= ' ') do inc(c);
if (c = endC) then Exit;
c2 := c;
if (c2^ = '-') then inc(c2);
if (c2^ = SvgDecimalSeparator) then inc(c2);
Result := (c2 < endC) and (c2^ >= '0') and (c2^ <= '9');
end;
//------------------------------------------------------------------------------
function ParseTransform(const transform: UTF8String): TMatrixD;
var
i: integer;
c, endC: PUTF8Char;
c2: UTF8Char;
word: UTF8String;
values: array[0..5] of double;
mat: TMatrixD;
begin
c := PUTF8Char(transform);
endC := c + Length(transform);
Result := IdentityMatrix; //in case of invalid or referenced value
while ParseNextWord(c, endC, word) do
begin
if Length(word) < 5 then Exit;
if ParseNextChar(c, endC) <> '(' then Exit; //syntax check
//reset values variables
for i := 0 to High(values) do values[i] := InvalidD;
//and since every transform function requires at least one value
if not ParseNextNum(c, endC, false, values[0]) then Break;
//now get additional variables
i := 1;
while (i < 6) and IsNumPending(c, endC, true) and
ParseNextNum(c, endC, true, values[i]) do inc(i);
if ParseNextChar(c, endC) <> ')' then Exit; //syntax check
mat := IdentityMatrix;
//scal(e), matr(i)x, tran(s)late, rota(t)e, skew(X), skew(Y)
case LowerCaseTable[word[5]] of
'e' : //scalE
if not IsValid(values[1]) then
MatrixScale(mat, values[0]) else
MatrixScale(mat, values[0], values[1]);
'i' : //matrIx
if IsValid(values[5]) then
begin
mat[0,0] := values[0];
mat[0,1] := values[1];
mat[1,0] := values[2];
mat[1,1] := values[3];
mat[2,0] := values[4];
mat[2,1] := values[5];
end;
's' : //tranSlateX, tranSlateY & tranSlate
if Length(word) =10 then
begin
c2 := LowerCaseTable[word[10]];
if c2 = 'x' then
MatrixTranslate(mat, values[0], 0)
else if c2 = 'y' then
MatrixTranslate(mat, 0, values[0]);
end
else if IsValid(values[1]) then
MatrixTranslate(mat, values[0], values[1])
else
MatrixTranslate(mat, values[0], 0);
't' : //rotaTe
if IsValid(values[2]) then
MatrixRotate(mat, PointD(values[1],values[2]), DegToRad(values[0]))
else
MatrixRotate(mat, NullPointD, DegToRad(values[0]));
'x' : //skewX
begin
MatrixSkew(mat, DegToRad(values[0]), 0);
end;
'y' : //skewY
begin
MatrixSkew(mat, 0, DegToRad(values[0]));
end;
end;
Result := MatrixMultiply(Result, mat);
end;
end;
//------------------------------------------------------------------------------
procedure GetSvgFontInfo(const value: UTF8String; var fontInfo: TSVGFontInfo);
var
c, endC: PUTF8Char;
hash: Cardinal;
begin
c := PUTF8Char(value);
endC := c + Length(value);
while (c < endC) and SkipBlanks(c, endC) do
begin
if c = ';' then
break
else if IsNumPending(c, endC, true) then
ParseNextNum(c, endC, true, fontInfo.size)
else
begin
hash := ParseNextWordHashed(c, endC);
case hash of
hSans_045_Serif : fontInfo.family := ttfSansSerif;
hSerif : fontInfo.family := ttfSerif;
hMonospace : fontInfo.family := ttfMonospace;
hBold : fontInfo.weight := 600;
hItalic : fontInfo.italic := sfsItalic;
hNormal :
begin
fontInfo.weight := 400;
fontInfo.italic := sfsNone;
end;
hStart : fontInfo.align := staLeft;
hMiddle : fontInfo.align := staCenter;
hEnd : fontInfo.align := staRight;
hline_045_through : fontInfo.decoration := fdStrikeThrough;
hUnderline : fontInfo.decoration := fdUnderline;
end;
end;
end;
end;
//------------------------------------------------------------------------------
function HtmlDecode(const html: UTF8String): UTF8String;
var
val, len: integer;
c,ce,endC: PUTF8Char;
begin
len := Length(html);
SetLength(Result, len*3);
c := PUTF8Char(html);
endC := c + len;
ce := c;
len := 1;
while (ce < endC) and (ce^ <> '&') do
inc(ce);
while (ce < endC) do
begin
if ce > c then
begin
Move(c^, Result[len], ce - c);
inc(len, ce - c);
end;
c := ce; inc(ce);
while (ce < endC) and (ce^ <> ';') do inc(ce);
if ce = endC then break;
val := -1; //assume error
if (c +1)^ = '#' then
begin
val := 0;
//decode unicode value
if (c +2)^ = 'x' then
begin
inc(c, 3);
while c < ce do
begin
if (c^ >= 'a') and (c^ <= 'f') then
val := val * 16 + Ord(c^) - 87
else if (c^ >= 'A') and (c^ <= 'F') then
val := val * 16 + Ord(c^) - 55
else if (c^ >= '0') and (c^ <= '9') then
val := val * 16 + Ord(c^) - 48
else
begin
val := -1;
break;
end;
inc(c);
end;
end else
begin
inc(c, 2);
while c < ce do
begin
val := val * 10 + Ord(c^) - 48;
inc(c);
end;
end;
end else
begin
//decode html entity ...
case GetHashCaseSensitive(c, ce - c) of
{$I Img32.SVG.HtmlValues.inc}
end;
end;
//convert unicode value to utf8 chars
//this saves the overhead of multiple UTF8String<-->string conversions.
case val of
0 .. $7F:
begin
result[len] := UTF8Char(val);
inc(len);
end;
$80 .. $7FF:
begin
Result[len] := UTF8Char($C0 or (val shr 6));
Result[len+1] := UTF8Char($80 or (val and $3f));
inc(len, 2);
end;
$800 .. $7FFF:
begin
Result[len] := UTF8Char($E0 or (val shr 12));
Result[len+1] := UTF8Char($80 or ((val shr 6) and $3f));
Result[len+2] := UTF8Char($80 or (val and $3f));
inc(len, 3);
end;
$10000 .. $10FFFF:
begin
Result[len] := UTF8Char($F0 or (val shr 18));
Result[len+1] := UTF8Char($80 or ((val shr 12) and $3f));
Result[len+2] := UTF8Char($80 or ((val shr 6) and $3f));
Result[len+3] := UTF8Char($80 or (val and $3f));
inc(len, 4);
end;
else
begin
//ie: error
Move(c^, Result[len], ce- c +1);
inc(len, ce - c +1);
end;
end;
inc(ce);
c := ce;
while (ce < endC) and (ce^ <> '&') do inc(ce);
end;
if (c < endC) and (ce > c) then
begin
Move(c^, Result[len], (ce - c));
inc(len, ce - c);
end;
setLength(Result, len -1);
end;
//------------------------------------------------------------------------------
function HexByteToInt(h: UTF8Char): Cardinal; {$IFDEF INLINE} inline; {$ENDIF}
begin
case h of
'0'..'9': Result := Ord(h) - Ord('0');
'A'..'F': Result := 10 + Ord(h) - Ord('A');
'a'..'f': Result := 10 + Ord(h) - Ord('a');
else Result := 0;
end;
end;
//------------------------------------------------------------------------------
function IsFraction(val: double): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
begin
Result := (val <> 0) and (Abs(val) < 1);
end;
//------------------------------------------------------------------------------
function UTF8StringToColor32(const value: UTF8String; var color: TColor32): Boolean;
var
i, len : integer;
j : Cardinal;
clr : TColor32;
alpha : Byte;
vals : array[0..3] of double;
mus : array[0..3] of TUnitType;
c, endC : PUTF8Char;
begin
Result := false;
len := Length(value);
if len < 3 then Exit;
c := PUTF8Char(value);
if (color = clInvalid) or (color = clCurrent) or (color = clNone32) then
alpha := 255 else
alpha := GetAlpha(color);
if Match(c, 'rgb') then
begin
endC := c + len;
inc(c, 3);
if (c^ = 'a') then inc(c);
if (ParseNextChar(c, endC) <> '(') or
not ParseNextNumEx(c, endC, false, vals[0], mus[0]) or
not ParseNextNumEx(c, endC, true, vals[1], mus[1]) or
not ParseNextNumEx(c, endC, true, vals[2], mus[2]) then Exit;
for i := 0 to 2 do
if mus[i] = utPercent then
vals[i] := vals[i] * 255 / 100;
if ParseNextNumEx(c, endC, true, vals[3], mus[3]) then
alpha := 255 else //stops further alpha adjustment
vals[3] := 255;
if ParseNextChar(c, endC) <> ')' then Exit;
for i := 0 to 3 do if IsFraction(vals[i]) then
vals[i] := vals[i] * 255;
color := ClampByte(Round(vals[3])) shl 24 +
ClampByte(Round(vals[0])) shl 16 +
ClampByte(Round(vals[1])) shl 8 +
ClampByte(Round(vals[2]));
end
else if (c^ = '#') then //#RRGGBB or #RGB
begin
if (len = 9) then
begin
clr := $0;
alpha := $0;
for i := 1 to 6 do
begin
inc(c);
clr := clr shl 4 + HexByteToInt(c^);
end;
for i := 1 to 2 do
begin
inc(c);
alpha := alpha shl 4 + HexByteToInt(c^);
end;
clr := clr or alpha shl 24;
end
else if (len = 7) then
begin
clr := $0;
for i := 1 to 6 do
begin
inc(c);
clr := clr shl 4 + HexByteToInt(c^);
end;
clr := clr or $FF000000;
end
else if (len = 5) then
begin
clr := $0;
for i := 1 to 3 do
begin
inc(c);
j := HexByteToInt(c^);
clr := clr shl 4 + j;
clr := clr shl 4 + j;
end;
inc(c);
alpha := HexByteToInt(c^);
alpha := alpha + alpha shl 4;
clr := clr or alpha shl 24;
end
else if (len = 4) then
begin
clr := $0;
for i := 1 to 3 do
begin
inc(c);
j := HexByteToInt(c^);
clr := clr shl 4 + j;
clr := clr shl 4 + j;
end;
clr := clr or $FF000000;
end
else
Exit;
color := clr;
end else //color name lookup
begin
i := ColorConstList.IndexOf(string(value));
if i < 0 then Exit;
color := TColorObj(ColorConstList.Objects[i]).cc.ColorValue;
end;
//and in case the opacity has been set before the color
if (alpha < 255) then
color := (color and $FFFFFF) or alpha shl 24;
{$IF DEFINED(ANDROID)}
color := SwapRedBlue(color);
{$IFEND}
Result := true;
end;
//------------------------------------------------------------------------------
function MakeDashArray(const dblArray: TArrayOfDouble; scale: double): TArrayOfInteger;
var
i, len: integer;
dist: double;
begin
dist := 0;
len := Length(dblArray);
SetLength(Result, len);
for i := 0 to len -1 do
begin
Result[i] := Ceil(dblArray[i] * scale);
dist := Result[i] + dist;
end;
if dist = 0 then
begin
Result := nil;
end
else if Odd(len) then
begin
SetLength(Result, len *2);
Move(Result[0], Result[len], len * SizeOf(integer));
end;
end;
//------------------------------------------------------------------------------
function PeekNextChar(var c: PUTF8Char; endC: PUTF8Char): UTF8Char;
begin
if not SkipBlanks(c, endC) then
Result := #0 else
Result := c^;
end;
//------------------------------------------------------------------------------
procedure ParseStyleElementContent(const value: UTF8String;
stylesList: TClassStylesList);
var
len, cap: integer;
names: array of string;
procedure AddName(const name: string);
begin
if len = cap then
begin
cap := cap + buffSize;
SetLength(names, cap);
end;
names[len] := name;
inc(len);
end;
var
i: integer;
aclassName: UTF8String;
aStyle: UTF8String;
c, c2, endC: PUTF8Char;
begin
//https://oreillymedia.github.io/Using_SVG/guide/style.html
stylesList.Clear;
if value = '' then Exit;
len := 0; cap := 0;
c := @value[1];
endC := c + Length(value);
SkipBlanks(c, endC);
if Match(c, ' '{' then Break;
inc(c);
c2 := c;
while (c < endC) and (c^ <> '}') do inc(c);
if (c = endC) then break;
aStyle := ToUTF8String(c2, c);
//finally, for each class name add (or append) this style
for i := 0 to High(names) do
stylesList.AddAppendStyle(names[i], aStyle);
names := nil;
len := 0; cap := 0;
inc(c);
end;
end;
//------------------------------------------------------------------------------
// TXmlEl classes
//------------------------------------------------------------------------------
constructor TXmlEl.Create(owner: TSvgParser);
begin
{$IFDEF XPLAT_GENERICS}
attribs := TList.Create;
childs := TList.Create;
{$ELSE}
attribs := TList.Create;
childs := TList.Create;
{$ENDIF}
selfClosed := true;
Self.owner := owner;
end;
//------------------------------------------------------------------------------
destructor TXmlEl.Destroy;
begin
Clear;
attribs.Free;
childs.Free;
inherited;
end;
//------------------------------------------------------------------------------
procedure TXmlEl.Clear;
var
i: integer;
begin
for i := 0 to attribs.Count -1 do
Dispose(PSvgAttrib(attribs[i]));
attribs.Clear;
for i := 0 to childs.Count -1 do
TXmlEl(childs[i]).free;
childs.Clear;
end;
//------------------------------------------------------------------------------
function TXmlEl.ParseHeader(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
style: UTF8String;
c2: PUTF8Char;
begin
SkipBlanks(c, endC);
c2 := c;;
ParseNameLength(c, endC);
name := ToUTF8String(c2, c);
//load the class's style (ie undotted style) if found.
style := owner.classStyles.GetStyle(name);
if style <> '' then ParseStyleAttribute(style);
Result := ParseAttributes(c, endC);
end;
//------------------------------------------------------------------------------
function TXmlEl.ParseAttribName(var c: PUTF8Char;
endC: PUTF8Char; attrib: PSvgAttrib): Boolean;
var
c2: PUTF8Char;
//attribName: UTF8String;
begin
Result := SkipBlanks(c, endC);
if not Result then Exit;
c2 := c;
ParseNameLength(c, endC);
attrib.Name := ToUTF8String(c2, c);
attrib.hash := GetHash(attrib.Name);
end;
//------------------------------------------------------------------------------
function TXmlEl.ParseAttribValue(var c: PUTF8Char;
endC: PUTF8Char; attrib: PSvgAttrib): Boolean;
var
quoteChar : UTF8Char;
c2, c3: PUTF8Char;
begin
Result := ParseNextChar(c, endC) = '=';
if not Result then Exit;
quoteChar := ParseQuoteChar(c, endC);
if quoteChar = #0 then Exit;
//trim leading and trailing spaces
while (c < endC) and (c^ <= space) do inc(c);
c2 := c;
while (c < endC) and (c^ <> quoteChar) do inc(c);
c3 := c;
while (c3 > c2) and ((c3 -1)^ <= space) do
dec(c3);
attrib.value := ToUTF8String(c2, c3);
inc(c); //skip end quote
end;
//------------------------------------------------------------------------------
function TXmlEl.ParseAttributes(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
i: integer;
attrib, styleAttrib, classAttrib, idAttrib: PSvgAttrib;
classes: UTF8Strings;
ansi: UTF8String;
begin
Result := false;
styleAttrib := nil; classAttrib := nil; idAttrib := nil;
while SkipBlanks(c, endC) do
begin
if CharInSet(c^, ['/', '?', '>']) then
begin
if (c^ <> '>') then
begin
inc(c);
if (c^ <> '>') then Exit; //error
selfClosed := true;
end;
inc(c);
Result := true;
break;
end
else if (c^ = 'x') and Match(c, 'xml:') then
begin
inc(c, 4); //ignore xml: prefixes
end;
New(attrib);
if not ParseAttribName(c, endC, attrib) or
not ParseAttribValue(c, endC, attrib) then
begin
Dispose(attrib);
Exit;
end;
attribs.Add(attrib);
case attrib.hash of
hId : idAttrib := attrib;
hClass : classAttrib := attrib;
hStyle : styleAttrib := attrib;
end;
end;
if assigned(classAttrib) then
with classAttrib^ do
begin
//get the 'dotted' classname(s)
classes := Split(value);
for i := 0 to High(classes) do
begin
ansi := SvgDecimalSeparator + classes[i];
//get the style definition
ansi := owner.classStyles.GetStyle(ansi);
if ansi <> '' then ParseStyleAttribute(ansi);
end;
end;
if assigned(styleAttrib) then
ParseStyleAttribute(styleAttrib.value);
if assigned(idAttrib) then
begin
//get the 'hashed' classname
ansi := '#' + idAttrib.value;
//get the style definition
ansi := owner.classStyles.GetStyle(ansi);
if ansi <> '' then ParseStyleAttribute(ansi);
end;
end;
//------------------------------------------------------------------------------
procedure TXmlEl.ParseStyleAttribute(const style: UTF8String);
var
styleName, styleVal: UTF8String;
c, c2, endC: PUTF8Char;
attrib: PSvgAttrib;
begin
//there are 4 ways to load styles (in ascending precedence) -
//1. a class element style (called during element contruction)
//2. a non-element class style (called via a class attribute)
//3. an inline style (called via a style attribute)
//4. an id specific class style
c := PUTF8Char(style);
endC := c + Length(style);
while SkipStyleBlanks(c, endC) do
begin
c2 := c;
ParseStyleNameLen(c, endC);
styleName := ToUTF8String(c2, c);
if styleName = '' then Break;
if (ParseNextChar(c, endC) <> ':') or //syntax check
not SkipBlanks(c,endC) then Break;
c2 := c;
inc(c);
while (c < endC) and (c^ <> ';') do inc(c);
styleVal := ToUTF8String(c2, c);
AllTrim(styleVal);
inc(c);
new(attrib);
attrib.name := styleName;
attrib.value := styleVal;
attrib.hash := GetHash(attrib.name);
attribs.Add(attrib);
end;
end;
//------------------------------------------------------------------------------
function TXmlEl.GetAttribCount: integer;
begin
Result := attribs.Count;
end;
//------------------------------------------------------------------------------
function TXmlEl.GetAttrib(index: integer): PSvgAttrib;
begin
Result := PSvgAttrib(attribs[index]);
end;
//------------------------------------------------------------------------------
function TXmlEl.ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
child: TSvgTreeEl;
entity: PSvgAttrib;
c2, tmpC, tmpEndC: PUTF8Char;
begin
Result := false;
while SkipBlanks(c, endC) do
begin
if (c^ = '<') then
begin
inc(c);
case c^ of
'!':
begin
if Match(c, '!--') then //start comment
begin
inc(c, 3);
while (c < endC) and ((c^ <> '-') or
not Match(c, '-->')) do inc(c); //end comment
inc(c, 3);
end else
begin
//it's very likely ']') or not Match(c, ']]>')) do
inc(c);
text := ToUTF8String(c2, c);
inc(c, 3);
if (hash = hStyle) then
ParseStyleElementContent(text, owner.classStyles);
end else
begin
while (c < endC) and (c^ <> '<') do inc(c);
text := ToUTF8String(c2, c);
end;
end;
end;
'/', '?':
begin
//element closing tag
inc(c);
if Match(c, name) then
begin
inc(c, Length(name));
//very rarely there's a space before '>'
SkipBlanks(c, endC);
Result := c^ = '>';
inc(c);
end;
Exit;
end;
else
begin
//starting a new element
child := TSvgTreeEl.Create(owner);
childs.Add(child);
if not child.ParseHeader(c, endC) then break;
if not child.selfClosed then
child.ParseContent(c, endC);
end;
end;
end
else if c^ = '>' then
begin
break; //oops! something's wrong
end
else if (c^ = '&') and IsKnownEntity(owner, c, endC, entity) then
begin
tmpC := PUTF8Char(entity.value);
tmpEndC := tmpC + Length(entity.value);
ParseContent(tmpC, tmpEndC);
end
else if (hash = hTSpan) or (hash = hText) or (hash = hTextPath) then
begin
//text content: and because text can be mixed with one or more
// elements we need to create sub-elements for each text block.
//And elements can even have sub-elements.
tmpC := c;
//preserve a leading space
if (tmpC -1)^ = space then dec(tmpC);
while (c < endC) and (c^ <> '<') do inc(c);
if (hash = hTextPath) then
begin
text := ToUTF8String(tmpC, c);
end else
begin
child := TSvgTreeEl.Create(owner);
childs.Add(child);
child.text := ToUTF8String(tmpC, c);
end;
end else
begin
tmpC := c;
while (c < endC) and (c^ <> '<') do inc(c);
text := ToUTF8String(tmpC, c);
//if