├── LICENSE
├── MAIN.ico
├── PV_Bitmap.pas
├── PV_BitmapFormats.pas
├── PV_CRC32Stream.pas
├── PV_Filters.pas
├── PV_Grayscale.pas
├── PV_Palette.pas
├── PV_Streams.pas
├── README.md
├── RLE.pas
├── dlg_about.lfm
├── dlg_about.pas
├── dlg_colors.lfm
├── dlg_colors.pas
├── dlg_formats.lfm
├── dlg_formats.pas
├── dlg_info.lfm
├── dlg_info.pas
├── dlg_params.lfm
├── dlg_params.pas
├── dlg_resize.lfm
├── dlg_resize.pas
├── fpwritegif.pas
├── icons
├── Farm-Fresh_clipboard_empty.png
├── browse.png
├── clip1.png
├── clip_copy.png
├── color.png
├── color_pick.png
├── copy.png
├── delete.png
├── filter.png
├── flip.png
├── fullscreen.png
├── open.png
├── options.png
├── print.png
├── refresh.png
├── resize.png
├── rotate180.png
├── rotate270.png
├── rotate90.png
├── save.png
├── screenshot.png
├── url.txt
├── zoom100.png
├── zoom_in.png
└── zoom_out.png
├── project1.ico
├── project1.lpi
├── project1.lpr
├── unit1.lfm
└── unit1.pas
/LICENSE:
--------------------------------------------------------------------------------
1 | GNU GENERAL PUBLIC LICENSE
2 | Version 3, 29 June 2007
3 |
4 | Copyright (C) 2007 Free Software Foundation, Inc.
5 | Everyone is permitted to copy and distribute verbatim copies
6 | of this license document, but changing it is not allowed.
7 |
8 | Preamble
9 |
10 | The GNU General Public License is a free, copyleft license for
11 | software and other kinds of works.
12 |
13 | The licenses for most software and other practical works are designed
14 | to take away your freedom to share and change the works. By contrast,
15 | the GNU General Public License is intended to guarantee your freedom to
16 | share and change all versions of a program--to make sure it remains free
17 | software for all its users. We, the Free Software Foundation, use the
18 | GNU General Public License for most of our software; it applies also to
19 | any other work released this way by its authors. You can apply it to
20 | your programs, too.
21 |
22 | When we speak of free software, we are referring to freedom, not
23 | price. Our General Public Licenses are designed to make sure that you
24 | have the freedom to distribute copies of free software (and charge for
25 | them if you wish), that you receive source code or can get it if you
26 | want it, that you can change the software or use pieces of it in new
27 | free programs, and that you know you can do these things.
28 |
29 | To protect your rights, we need to prevent others from denying you
30 | these rights or asking you to surrender the rights. Therefore, you have
31 | certain responsibilities if you distribute copies of the software, or if
32 | you modify it: responsibilities to respect the freedom of others.
33 |
34 | For example, if you distribute copies of such a program, whether
35 | gratis or for a fee, you must pass on to the recipients the same
36 | freedoms that you received. You must make sure that they, too, receive
37 | or can get the source code. And you must show them these terms so they
38 | know their rights.
39 |
40 | Developers that use the GNU GPL protect your rights with two steps:
41 | (1) assert copyright on the software, and (2) offer you this License
42 | giving you legal permission to copy, distribute and/or modify it.
43 |
44 | For the developers' and authors' protection, the GPL clearly explains
45 | that there is no warranty for this free software. For both users' and
46 | authors' sake, the GPL requires that modified versions be marked as
47 | changed, so that their problems will not be attributed erroneously to
48 | authors of previous versions.
49 |
50 | Some devices are designed to deny users access to install or run
51 | modified versions of the software inside them, although the manufacturer
52 | can do so. This is fundamentally incompatible with the aim of
53 | protecting users' freedom to change the software. The systematic
54 | pattern of such abuse occurs in the area of products for individuals to
55 | use, which is precisely where it is most unacceptable. Therefore, we
56 | have designed this version of the GPL to prohibit the practice for those
57 | products. If such problems arise substantially in other domains, we
58 | stand ready to extend this provision to those domains in future versions
59 | of the GPL, as needed to protect the freedom of users.
60 |
61 | Finally, every program is threatened constantly by software patents.
62 | States should not allow patents to restrict development and use of
63 | software on general-purpose computers, but in those that do, we wish to
64 | avoid the special danger that patents applied to a free program could
65 | make it effectively proprietary. To prevent this, the GPL assures that
66 | patents cannot be used to render the program non-free.
67 |
68 | The precise terms and conditions for copying, distribution and
69 | modification follow.
70 |
71 | TERMS AND CONDITIONS
72 |
73 | 0. Definitions.
74 |
75 | "This License" refers to version 3 of the GNU General Public License.
76 |
77 | "Copyright" also means copyright-like laws that apply to other kinds of
78 | works, such as semiconductor masks.
79 |
80 | "The Program" refers to any copyrightable work licensed under this
81 | License. Each licensee is addressed as "you". "Licensees" and
82 | "recipients" may be individuals or organizations.
83 |
84 | To "modify" a work means to copy from or adapt all or part of the work
85 | in a fashion requiring copyright permission, other than the making of an
86 | exact copy. The resulting work is called a "modified version" of the
87 | earlier work or a work "based on" the earlier work.
88 |
89 | A "covered work" means either the unmodified Program or a work based
90 | on the Program.
91 |
92 | To "propagate" a work means to do anything with it that, without
93 | permission, would make you directly or secondarily liable for
94 | infringement under applicable copyright law, except executing it on a
95 | computer or modifying a private copy. Propagation includes copying,
96 | distribution (with or without modification), making available to the
97 | public, and in some countries other activities as well.
98 |
99 | To "convey" a work means any kind of propagation that enables other
100 | parties to make or receive copies. Mere interaction with a user through
101 | a computer network, with no transfer of a copy, is not conveying.
102 |
103 | An interactive user interface displays "Appropriate Legal Notices"
104 | to the extent that it includes a convenient and prominently visible
105 | feature that (1) displays an appropriate copyright notice, and (2)
106 | tells the user that there is no warranty for the work (except to the
107 | extent that warranties are provided), that licensees may convey the
108 | work under this License, and how to view a copy of this License. If
109 | the interface presents a list of user commands or options, such as a
110 | menu, a prominent item in the list meets this criterion.
111 |
112 | 1. Source Code.
113 |
114 | The "source code" for a work means the preferred form of the work
115 | for making modifications to it. "Object code" means any non-source
116 | form of a work.
117 |
118 | A "Standard Interface" means an interface that either is an official
119 | standard defined by a recognized standards body, or, in the case of
120 | interfaces specified for a particular programming language, one that
121 | is widely used among developers working in that language.
122 |
123 | The "System Libraries" of an executable work include anything, other
124 | than the work as a whole, that (a) is included in the normal form of
125 | packaging a Major Component, but which is not part of that Major
126 | Component, and (b) serves only to enable use of the work with that
127 | Major Component, or to implement a Standard Interface for which an
128 | implementation is available to the public in source code form. A
129 | "Major Component", in this context, means a major essential component
130 | (kernel, window system, and so on) of the specific operating system
131 | (if any) on which the executable work runs, or a compiler used to
132 | produce the work, or an object code interpreter used to run it.
133 |
134 | The "Corresponding Source" for a work in object code form means all
135 | the source code needed to generate, install, and (for an executable
136 | work) run the object code and to modify the work, including scripts to
137 | control those activities. However, it does not include the work's
138 | System Libraries, or general-purpose tools or generally available free
139 | programs which are used unmodified in performing those activities but
140 | which are not part of the work. For example, Corresponding Source
141 | includes interface definition files associated with source files for
142 | the work, and the source code for shared libraries and dynamically
143 | linked subprograms that the work is specifically designed to require,
144 | such as by intimate data communication or control flow between those
145 | subprograms and other parts of the work.
146 |
147 | The Corresponding Source need not include anything that users
148 | can regenerate automatically from other parts of the Corresponding
149 | Source.
150 |
151 | The Corresponding Source for a work in source code form is that
152 | same work.
153 |
154 | 2. Basic Permissions.
155 |
156 | All rights granted under this License are granted for the term of
157 | copyright on the Program, and are irrevocable provided the stated
158 | conditions are met. This License explicitly affirms your unlimited
159 | permission to run the unmodified Program. The output from running a
160 | covered work is covered by this License only if the output, given its
161 | content, constitutes a covered work. This License acknowledges your
162 | rights of fair use or other equivalent, as provided by copyright law.
163 |
164 | You may make, run and propagate covered works that you do not
165 | convey, without conditions so long as your license otherwise remains
166 | in force. You may convey covered works to others for the sole purpose
167 | of having them make modifications exclusively for you, or provide you
168 | with facilities for running those works, provided that you comply with
169 | the terms of this License in conveying all material for which you do
170 | not control copyright. Those thus making or running the covered works
171 | for you must do so exclusively on your behalf, under your direction
172 | and control, on terms that prohibit them from making any copies of
173 | your copyrighted material outside their relationship with you.
174 |
175 | Conveying under any other circumstances is permitted solely under
176 | the conditions stated below. Sublicensing is not allowed; section 10
177 | makes it unnecessary.
178 |
179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
180 |
181 | No covered work shall be deemed part of an effective technological
182 | measure under any applicable law fulfilling obligations under article
183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or
184 | similar laws prohibiting or restricting circumvention of such
185 | measures.
186 |
187 | When you convey a covered work, you waive any legal power to forbid
188 | circumvention of technological measures to the extent such circumvention
189 | is effected by exercising rights under this License with respect to
190 | the covered work, and you disclaim any intention to limit operation or
191 | modification of the work as a means of enforcing, against the work's
192 | users, your or third parties' legal rights to forbid circumvention of
193 | technological measures.
194 |
195 | 4. Conveying Verbatim Copies.
196 |
197 | You may convey verbatim copies of the Program's source code as you
198 | receive it, in any medium, provided that you conspicuously and
199 | appropriately publish on each copy an appropriate copyright notice;
200 | keep intact all notices stating that this License and any
201 | non-permissive terms added in accord with section 7 apply to the code;
202 | keep intact all notices of the absence of any warranty; and give all
203 | recipients a copy of this License along with the Program.
204 |
205 | You may charge any price or no price for each copy that you convey,
206 | and you may offer support or warranty protection for a fee.
207 |
208 | 5. Conveying Modified Source Versions.
209 |
210 | You may convey a work based on the Program, or the modifications to
211 | produce it from the Program, in the form of source code under the
212 | terms of section 4, provided that you also meet all of these conditions:
213 |
214 | a) The work must carry prominent notices stating that you modified
215 | it, and giving a relevant date.
216 |
217 | b) The work must carry prominent notices stating that it is
218 | released under this License and any conditions added under section
219 | 7. This requirement modifies the requirement in section 4 to
220 | "keep intact all notices".
221 |
222 | c) You must license the entire work, as a whole, under this
223 | License to anyone who comes into possession of a copy. This
224 | License will therefore apply, along with any applicable section 7
225 | additional terms, to the whole of the work, and all its parts,
226 | regardless of how they are packaged. This License gives no
227 | permission to license the work in any other way, but it does not
228 | invalidate such permission if you have separately received it.
229 |
230 | d) If the work has interactive user interfaces, each must display
231 | Appropriate Legal Notices; however, if the Program has interactive
232 | interfaces that do not display Appropriate Legal Notices, your
233 | work need not make them do so.
234 |
235 | A compilation of a covered work with other separate and independent
236 | works, which are not by their nature extensions of the covered work,
237 | and which are not combined with it such as to form a larger program,
238 | in or on a volume of a storage or distribution medium, is called an
239 | "aggregate" if the compilation and its resulting copyright are not
240 | used to limit the access or legal rights of the compilation's users
241 | beyond what the individual works permit. Inclusion of a covered work
242 | in an aggregate does not cause this License to apply to the other
243 | parts of the aggregate.
244 |
245 | 6. Conveying Non-Source Forms.
246 |
247 | You may convey a covered work in object code form under the terms
248 | of sections 4 and 5, provided that you also convey the
249 | machine-readable Corresponding Source under the terms of this License,
250 | in one of these ways:
251 |
252 | a) Convey the object code in, or embodied in, a physical product
253 | (including a physical distribution medium), accompanied by the
254 | Corresponding Source fixed on a durable physical medium
255 | customarily used for software interchange.
256 |
257 | b) Convey the object code in, or embodied in, a physical product
258 | (including a physical distribution medium), accompanied by a
259 | written offer, valid for at least three years and valid for as
260 | long as you offer spare parts or customer support for that product
261 | model, to give anyone who possesses the object code either (1) a
262 | copy of the Corresponding Source for all the software in the
263 | product that is covered by this License, on a durable physical
264 | medium customarily used for software interchange, for a price no
265 | more than your reasonable cost of physically performing this
266 | conveying of source, or (2) access to copy the
267 | Corresponding Source from a network server at no charge.
268 |
269 | c) Convey individual copies of the object code with a copy of the
270 | written offer to provide the Corresponding Source. This
271 | alternative is allowed only occasionally and noncommercially, and
272 | only if you received the object code with such an offer, in accord
273 | with subsection 6b.
274 |
275 | d) Convey the object code by offering access from a designated
276 | place (gratis or for a charge), and offer equivalent access to the
277 | Corresponding Source in the same way through the same place at no
278 | further charge. You need not require recipients to copy the
279 | Corresponding Source along with the object code. If the place to
280 | copy the object code is a network server, the Corresponding Source
281 | may be on a different server (operated by you or a third party)
282 | that supports equivalent copying facilities, provided you maintain
283 | clear directions next to the object code saying where to find the
284 | Corresponding Source. Regardless of what server hosts the
285 | Corresponding Source, you remain obligated to ensure that it is
286 | available for as long as needed to satisfy these requirements.
287 |
288 | e) Convey the object code using peer-to-peer transmission, provided
289 | you inform other peers where the object code and Corresponding
290 | Source of the work are being offered to the general public at no
291 | charge under subsection 6d.
292 |
293 | A separable portion of the object code, whose source code is excluded
294 | from the Corresponding Source as a System Library, need not be
295 | included in conveying the object code work.
296 |
297 | A "User Product" is either (1) a "consumer product", which means any
298 | tangible personal property which is normally used for personal, family,
299 | or household purposes, or (2) anything designed or sold for incorporation
300 | into a dwelling. In determining whether a product is a consumer product,
301 | doubtful cases shall be resolved in favor of coverage. For a particular
302 | product received by a particular user, "normally used" refers to a
303 | typical or common use of that class of product, regardless of the status
304 | of the particular user or of the way in which the particular user
305 | actually uses, or expects or is expected to use, the product. A product
306 | is a consumer product regardless of whether the product has substantial
307 | commercial, industrial or non-consumer uses, unless such uses represent
308 | the only significant mode of use of the product.
309 |
310 | "Installation Information" for a User Product means any methods,
311 | procedures, authorization keys, or other information required to install
312 | and execute modified versions of a covered work in that User Product from
313 | a modified version of its Corresponding Source. The information must
314 | suffice to ensure that the continued functioning of the modified object
315 | code is in no case prevented or interfered with solely because
316 | modification has been made.
317 |
318 | If you convey an object code work under this section in, or with, or
319 | specifically for use in, a User Product, and the conveying occurs as
320 | part of a transaction in which the right of possession and use of the
321 | User Product is transferred to the recipient in perpetuity or for a
322 | fixed term (regardless of how the transaction is characterized), the
323 | Corresponding Source conveyed under this section must be accompanied
324 | by the Installation Information. But this requirement does not apply
325 | if neither you nor any third party retains the ability to install
326 | modified object code on the User Product (for example, the work has
327 | been installed in ROM).
328 |
329 | The requirement to provide Installation Information does not include a
330 | requirement to continue to provide support service, warranty, or updates
331 | for a work that has been modified or installed by the recipient, or for
332 | the User Product in which it has been modified or installed. Access to a
333 | network may be denied when the modification itself materially and
334 | adversely affects the operation of the network or violates the rules and
335 | protocols for communication across the network.
336 |
337 | Corresponding Source conveyed, and Installation Information provided,
338 | in accord with this section must be in a format that is publicly
339 | documented (and with an implementation available to the public in
340 | source code form), and must require no special password or key for
341 | unpacking, reading or copying.
342 |
343 | 7. Additional Terms.
344 |
345 | "Additional permissions" are terms that supplement the terms of this
346 | License by making exceptions from one or more of its conditions.
347 | Additional permissions that are applicable to the entire Program shall
348 | be treated as though they were included in this License, to the extent
349 | that they are valid under applicable law. If additional permissions
350 | apply only to part of the Program, that part may be used separately
351 | under those permissions, but the entire Program remains governed by
352 | this License without regard to the additional permissions.
353 |
354 | When you convey a copy of a covered work, you may at your option
355 | remove any additional permissions from that copy, or from any part of
356 | it. (Additional permissions may be written to require their own
357 | removal in certain cases when you modify the work.) You may place
358 | additional permissions on material, added by you to a covered work,
359 | for which you have or can give appropriate copyright permission.
360 |
361 | Notwithstanding any other provision of this License, for material you
362 | add to a covered work, you may (if authorized by the copyright holders of
363 | that material) supplement the terms of this License with terms:
364 |
365 | a) Disclaiming warranty or limiting liability differently from the
366 | terms of sections 15 and 16 of this License; or
367 |
368 | b) Requiring preservation of specified reasonable legal notices or
369 | author attributions in that material or in the Appropriate Legal
370 | Notices displayed by works containing it; or
371 |
372 | c) Prohibiting misrepresentation of the origin of that material, or
373 | requiring that modified versions of such material be marked in
374 | reasonable ways as different from the original version; or
375 |
376 | d) Limiting the use for publicity purposes of names of licensors or
377 | authors of the material; or
378 |
379 | e) Declining to grant rights under trademark law for use of some
380 | trade names, trademarks, or service marks; or
381 |
382 | f) Requiring indemnification of licensors and authors of that
383 | material by anyone who conveys the material (or modified versions of
384 | it) with contractual assumptions of liability to the recipient, for
385 | any liability that these contractual assumptions directly impose on
386 | those licensors and authors.
387 |
388 | All other non-permissive additional terms are considered "further
389 | restrictions" within the meaning of section 10. If the Program as you
390 | received it, or any part of it, contains a notice stating that it is
391 | governed by this License along with a term that is a further
392 | restriction, you may remove that term. If a license document contains
393 | a further restriction but permits relicensing or conveying under this
394 | License, you may add to a covered work material governed by the terms
395 | of that license document, provided that the further restriction does
396 | not survive such relicensing or conveying.
397 |
398 | If you add terms to a covered work in accord with this section, you
399 | must place, in the relevant source files, a statement of the
400 | additional terms that apply to those files, or a notice indicating
401 | where to find the applicable terms.
402 |
403 | Additional terms, permissive or non-permissive, may be stated in the
404 | form of a separately written license, or stated as exceptions;
405 | the above requirements apply either way.
406 |
407 | 8. Termination.
408 |
409 | You may not propagate or modify a covered work except as expressly
410 | provided under this License. Any attempt otherwise to propagate or
411 | modify it is void, and will automatically terminate your rights under
412 | this License (including any patent licenses granted under the third
413 | paragraph of section 11).
414 |
415 | However, if you cease all violation of this License, then your
416 | license from a particular copyright holder is reinstated (a)
417 | provisionally, unless and until the copyright holder explicitly and
418 | finally terminates your license, and (b) permanently, if the copyright
419 | holder fails to notify you of the violation by some reasonable means
420 | prior to 60 days after the cessation.
421 |
422 | Moreover, your license from a particular copyright holder is
423 | reinstated permanently if the copyright holder notifies you of the
424 | violation by some reasonable means, this is the first time you have
425 | received notice of violation of this License (for any work) from that
426 | copyright holder, and you cure the violation prior to 30 days after
427 | your receipt of the notice.
428 |
429 | Termination of your rights under this section does not terminate the
430 | licenses of parties who have received copies or rights from you under
431 | this License. If your rights have been terminated and not permanently
432 | reinstated, you do not qualify to receive new licenses for the same
433 | material under section 10.
434 |
435 | 9. Acceptance Not Required for Having Copies.
436 |
437 | You are not required to accept this License in order to receive or
438 | run a copy of the Program. Ancillary propagation of a covered work
439 | occurring solely as a consequence of using peer-to-peer transmission
440 | to receive a copy likewise does not require acceptance. However,
441 | nothing other than this License grants you permission to propagate or
442 | modify any covered work. These actions infringe copyright if you do
443 | not accept this License. Therefore, by modifying or propagating a
444 | covered work, you indicate your acceptance of this License to do so.
445 |
446 | 10. Automatic Licensing of Downstream Recipients.
447 |
448 | Each time you convey a covered work, the recipient automatically
449 | receives a license from the original licensors, to run, modify and
450 | propagate that work, subject to this License. You are not responsible
451 | for enforcing compliance by third parties with this License.
452 |
453 | An "entity transaction" is a transaction transferring control of an
454 | organization, or substantially all assets of one, or subdividing an
455 | organization, or merging organizations. If propagation of a covered
456 | work results from an entity transaction, each party to that
457 | transaction who receives a copy of the work also receives whatever
458 | licenses to the work the party's predecessor in interest had or could
459 | give under the previous paragraph, plus a right to possession of the
460 | Corresponding Source of the work from the predecessor in interest, if
461 | the predecessor has it or can get it with reasonable efforts.
462 |
463 | You may not impose any further restrictions on the exercise of the
464 | rights granted or affirmed under this License. For example, you may
465 | not impose a license fee, royalty, or other charge for exercise of
466 | rights granted under this License, and you may not initiate litigation
467 | (including a cross-claim or counterclaim in a lawsuit) alleging that
468 | any patent claim is infringed by making, using, selling, offering for
469 | sale, or importing the Program or any portion of it.
470 |
471 | 11. Patents.
472 |
473 | A "contributor" is a copyright holder who authorizes use under this
474 | License of the Program or a work on which the Program is based. The
475 | work thus licensed is called the contributor's "contributor version".
476 |
477 | A contributor's "essential patent claims" are all patent claims
478 | owned or controlled by the contributor, whether already acquired or
479 | hereafter acquired, that would be infringed by some manner, permitted
480 | by this License, of making, using, or selling its contributor version,
481 | but do not include claims that would be infringed only as a
482 | consequence of further modification of the contributor version. For
483 | purposes of this definition, "control" includes the right to grant
484 | patent sublicenses in a manner consistent with the requirements of
485 | this License.
486 |
487 | Each contributor grants you a non-exclusive, worldwide, royalty-free
488 | patent license under the contributor's essential patent claims, to
489 | make, use, sell, offer for sale, import and otherwise run, modify and
490 | propagate the contents of its contributor version.
491 |
492 | In the following three paragraphs, a "patent license" is any express
493 | agreement or commitment, however denominated, not to enforce a patent
494 | (such as an express permission to practice a patent or covenant not to
495 | sue for patent infringement). To "grant" such a patent license to a
496 | party means to make such an agreement or commitment not to enforce a
497 | patent against the party.
498 |
499 | If you convey a covered work, knowingly relying on a patent license,
500 | and the Corresponding Source of the work is not available for anyone
501 | to copy, free of charge and under the terms of this License, through a
502 | publicly available network server or other readily accessible means,
503 | then you must either (1) cause the Corresponding Source to be so
504 | available, or (2) arrange to deprive yourself of the benefit of the
505 | patent license for this particular work, or (3) arrange, in a manner
506 | consistent with the requirements of this License, to extend the patent
507 | license to downstream recipients. "Knowingly relying" means you have
508 | actual knowledge that, but for the patent license, your conveying the
509 | covered work in a country, or your recipient's use of the covered work
510 | in a country, would infringe one or more identifiable patents in that
511 | country that you have reason to believe are valid.
512 |
513 | If, pursuant to or in connection with a single transaction or
514 | arrangement, you convey, or propagate by procuring conveyance of, a
515 | covered work, and grant a patent license to some of the parties
516 | receiving the covered work authorizing them to use, propagate, modify
517 | or convey a specific copy of the covered work, then the patent license
518 | you grant is automatically extended to all recipients of the covered
519 | work and works based on it.
520 |
521 | A patent license is "discriminatory" if it does not include within
522 | the scope of its coverage, prohibits the exercise of, or is
523 | conditioned on the non-exercise of one or more of the rights that are
524 | specifically granted under this License. You may not convey a covered
525 | work if you are a party to an arrangement with a third party that is
526 | in the business of distributing software, under which you make payment
527 | to the third party based on the extent of your activity of conveying
528 | the work, and under which the third party grants, to any of the
529 | parties who would receive the covered work from you, a discriminatory
530 | patent license (a) in connection with copies of the covered work
531 | conveyed by you (or copies made from those copies), or (b) primarily
532 | for and in connection with specific products or compilations that
533 | contain the covered work, unless you entered into that arrangement,
534 | or that patent license was granted, prior to 28 March 2007.
535 |
536 | Nothing in this License shall be construed as excluding or limiting
537 | any implied license or other defenses to infringement that may
538 | otherwise be available to you under applicable patent law.
539 |
540 | 12. No Surrender of Others' Freedom.
541 |
542 | If conditions are imposed on you (whether by court order, agreement or
543 | otherwise) that contradict the conditions of this License, they do not
544 | excuse you from the conditions of this License. If you cannot convey a
545 | covered work so as to satisfy simultaneously your obligations under this
546 | License and any other pertinent obligations, then as a consequence you may
547 | not convey it at all. For example, if you agree to terms that obligate you
548 | to collect a royalty for further conveying from those to whom you convey
549 | the Program, the only way you could satisfy both those terms and this
550 | License would be to refrain entirely from conveying the Program.
551 |
552 | 13. Use with the GNU Affero General Public License.
553 |
554 | Notwithstanding any other provision of this License, you have
555 | permission to link or combine any covered work with a work licensed
556 | under version 3 of the GNU Affero General Public License into a single
557 | combined work, and to convey the resulting work. The terms of this
558 | License will continue to apply to the part which is the covered work,
559 | but the special requirements of the GNU Affero General Public License,
560 | section 13, concerning interaction through a network will apply to the
561 | combination as such.
562 |
563 | 14. Revised Versions of this License.
564 |
565 | The Free Software Foundation may publish revised and/or new versions of
566 | the GNU General Public License from time to time. Such new versions will
567 | be similar in spirit to the present version, but may differ in detail to
568 | address new problems or concerns.
569 |
570 | Each version is given a distinguishing version number. If the
571 | Program specifies that a certain numbered version of the GNU General
572 | Public License "or any later version" applies to it, you have the
573 | option of following the terms and conditions either of that numbered
574 | version or of any later version published by the Free Software
575 | Foundation. If the Program does not specify a version number of the
576 | GNU General Public License, you may choose any version ever published
577 | by the Free Software Foundation.
578 |
579 | If the Program specifies that a proxy can decide which future
580 | versions of the GNU General Public License can be used, that proxy's
581 | public statement of acceptance of a version permanently authorizes you
582 | to choose that version for the Program.
583 |
584 | Later license versions may give you additional or different
585 | permissions. However, no additional obligations are imposed on any
586 | author or copyright holder as a result of your choosing to follow a
587 | later version.
588 |
589 | 15. Disclaimer of Warranty.
590 |
591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
599 |
600 | 16. Limitation of Liability.
601 |
602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
610 | SUCH DAMAGES.
611 |
612 | 17. Interpretation of Sections 15 and 16.
613 |
614 | If the disclaimer of warranty and limitation of liability provided
615 | above cannot be given local legal effect according to their terms,
616 | reviewing courts shall apply local law that most closely approximates
617 | an absolute waiver of all civil liability in connection with the
618 | Program, unless a warranty or assumption of liability accompanies a
619 | copy of the Program in return for a fee.
620 |
621 | END OF TERMS AND CONDITIONS
622 |
623 | How to Apply These Terms to Your New Programs
624 |
625 | If you develop a new program, and you want it to be of the greatest
626 | possible use to the public, the best way to achieve this is to make it
627 | free software which everyone can redistribute and change under these terms.
628 |
629 | To do so, attach the following notices to the program. It is safest
630 | to attach them to the start of each source file to most effectively
631 | state the exclusion of warranty; and each file should have at least
632 | the "copyright" line and a pointer to where the full notice is found.
633 |
634 |
635 | Copyright (C)
636 |
637 | This program is free software: you can redistribute it and/or modify
638 | it under the terms of the GNU General Public License as published by
639 | the Free Software Foundation, either version 3 of the License, or
640 | (at your option) any later version.
641 |
642 | This program is distributed in the hope that it will be useful,
643 | but WITHOUT ANY WARRANTY; without even the implied warranty of
644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
645 | GNU General Public License for more details.
646 |
647 | You should have received a copy of the GNU General Public License
648 | along with this program. If not, see .
649 |
650 | Also add information on how to contact you by electronic and paper mail.
651 |
652 | If the program does terminal interaction, make it output a short
653 | notice like this when it starts in an interactive mode:
654 |
655 | Copyright (C)
656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
657 | This is free software, and you are welcome to redistribute it
658 | under certain conditions; type `show c' for details.
659 |
660 | The hypothetical commands `show w' and `show c' should show the appropriate
661 | parts of the General Public License. Of course, your program's commands
662 | might be different; for a GUI interface, you would use an "about box".
663 |
664 | You should also get your employer (if you work as a programmer) or school,
665 | if any, to sign a "copyright disclaimer" for the program, if necessary.
666 | For more information on this, and how to apply and follow the GNU GPL, see
667 | .
668 |
669 | The GNU General Public License does not permit incorporating your program
670 | into proprietary programs. If your program is a subroutine library, you
671 | may consider it more useful to permit linking proprietary applications with
672 | the library. If this is what you want to do, use the GNU Lesser General
673 | Public License instead of this License. But first, please read
674 | .
675 |
--------------------------------------------------------------------------------
/MAIN.ico:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/MAIN.ico
--------------------------------------------------------------------------------
/PV_Bitmap.pas:
--------------------------------------------------------------------------------
1 | unit PV_Bitmap;
2 |
3 | //Lazzy Image Viewer
4 | //github.com/PascalVault
5 | //License: MIT
6 |
7 | {$inline on}
8 | interface
9 |
10 | uses Classes, Graphics, SysUtils, DateUtils, Math, IntfGraphics, FPImage, Dialogs, PV_Streams;
11 |
12 | const PaletteMono: array[0..1] of Cardinal = ($FFFFFFFF, $FF000000);
13 |
14 | type
15 | {$IFDEF WINDOWS}
16 | TPix = packed record
17 | case Byte of
18 | 1: (B,G,R,A: Byte);
19 | 2: (RGBA: Cardinal);
20 | end;
21 | {$ELSE}
22 | TPix = packed record
23 | case Byte of
24 | 1: (B,G,R,A: Byte);
25 | 2: (RGBA: Cardinal);
26 | end;
27 | {$ENDIF}
28 | TPal = record
29 | R,G,B: Byte;
30 | end;
31 |
32 | TPix3 = Cardinal;
33 |
34 | PPixArray = ^TPixArray;
35 | TPixArray = array[0..32766] of TPix;
36 |
37 | PPix = ^TPix;
38 | TPalArray = array of TPix;
39 | TDither = (ddNone, ddFloyd, ddBurkes, ddStucki, ddJarvis, ddAtkinson, ddSierra2, ddSierra3, ddSierra4);
40 | TPixInt = record
41 | R,G,B: Integer;
42 | end;
43 |
44 |
45 | { TPV_Bitmap }
46 |
47 | TPV_Bitmap = class
48 | public
49 | function GetPixel(X,Y: Integer): TPix;
50 | procedure SetPixel(X,Y: Integer; Val: TPix); inline;
51 | private
52 | FData: array of TPix;
53 | FWidth: Integer;
54 | FHeight: Integer;
55 |
56 | function GetWidth: Integer;
57 | procedure SetWidth(Val: Integer);
58 | function GetHeight: Integer;
59 | procedure SetHeight(Val: Integer);
60 | function GetScanline(Y: Integer): Pointer;
61 | public
62 | FPalette: array of TPix;
63 | PaletteLen: Integer;
64 | FormatName: String;
65 |
66 | procedure SetMono(X,Y: Integer; B: Byte); inline;
67 | procedure SetRGBA(X,Y: Integer; R,G,B,A: Byte); inline;
68 | procedure SetRGB(X,Y: Integer; R,G,B: Byte); inline;
69 | procedure Set32(X,Y: Integer; Val: Cardinal); inline; overload;
70 | procedure Set32(X,Y: Integer; Val: TPal); inline; overload;
71 |
72 | procedure SetR(X,Y: Integer; R: Byte); inline;
73 | procedure SetG(X,Y: Integer; G: Byte); inline;
74 | procedure SetB(X,Y: Integer; B: Byte); inline;
75 | procedure SetA(X,Y: Integer; A: Byte); inline;
76 |
77 | procedure AddPal(R,G,B,A: Byte);
78 | procedure SetPal(X,Y: Integer; Index: Byte); inline;
79 | function GetPalIndex(X,Y: Integer): Integer;
80 | procedure AddPalette(Pal: array of TPal; Len: Integer);
81 | procedure ClearPalette;
82 |
83 | property Scanline[Y: Integer]: Pointer read GetScanline;
84 | property Pixel[X,Y: Integer]: TPix read GetPixel write SetPixel; default;
85 | property Width: Integer read GetWidth write SetWidth;
86 | property Height: Integer read GetHeight write SetHeight;
87 |
88 | constructor Create;
89 | procedure SetSize(AWidth, AHeight: Integer);
90 | function LoadFromFile(Filename: String): Boolean;
91 | procedure SaveToFile(Filename: String); overload;
92 | procedure SaveToFile(Filename: String; Compression: Byte); overload;
93 | procedure Draw(Bitmap: TPV_Bitmap; Left,Top, AWidth,AHeight: Integer);
94 | procedure FlipH;
95 | procedure FlipV;
96 |
97 | procedure CopyFrom(Bitmap: TPV_Bitmap);
98 | procedure CopyFrom(Bitmap: TBitmap);
99 | procedure CopyFrom(Bitmap: TFPMemoryImage);
100 | function GetPiece(AX,AY, AWidth,AHeight: Integer): TBitmap;
101 |
102 | procedure ReduceColors(MaxColors: Byte; Dither: TDither = ddFloyd);
103 | procedure Grayscale(MaxColors: Byte; Dither: TDither = ddFloyd);
104 | procedure BlackWhite(Dither: TDither = ddFloyd);
105 | procedure Highcolor(Bits: Integer = 16);
106 |
107 | procedure Resize(AWidth, AHeight: Integer);
108 | procedure ResizePercent(AWidth, AHeight: Integer);
109 | procedure RemoveAlpha;
110 | procedure Opaque;
111 |
112 | function ToBitmap: TBitmap;
113 | procedure DrawTo(X,Y: Integer; Canvas: TCanvas);
114 | procedure DrawTo(Dest: TRect; Canvas: TCanvas); overload;
115 |
116 | procedure Trim(RR,GG,BB: Byte);
117 | function CountColors: Integer;
118 | public
119 |
120 | end;
121 |
122 | TPV_BitmapReader = function(Bmp: TPV_Bitmap; Str: TStream): Boolean;
123 | TPV_BitmapWriter = procedure(Bmp: TPV_Bitmap; Str: TStream; Compression: Byte);
124 |
125 | TXBmpFormat = record
126 | Ext: String;
127 | Reader: TPV_BitmapReader;
128 | Writer: TPV_BitmapWriter;
129 | Name: String;
130 | end;
131 |
132 | { TPV_BitmapFormat }
133 |
134 | TPV_BitmapFormat = class
135 | private
136 | FList: array of TXBmpFormat;
137 | FCount: Integer;
138 | public
139 | property Count: Integer read FCount;
140 | procedure Item(Index: Integer; out Ext,Name: String; out Reader: TPV_BitmapReader; out Writer: TPV_BitmapWriter);
141 | constructor Create;
142 | function FindReader(Ext: String; out Format: String): TPV_BitmapReader;
143 | function FindWriter(Ext: String): TPV_BitmapWriter;
144 | function FindName(Ext: String): String;
145 | procedure Add(Ext: String; Reader: TPV_BitmapReader; Writer: TPV_BitmapWriter; Name: String);
146 | end;
147 |
148 | function MakePix(R,G,B,A: Byte): TPix;
149 | function Clip(V: Extended): Byte;
150 | function SamePix(P,R: TPix; Threshold: Byte = 5): Boolean;
151 | function Limit(Min,Max,Val: Integer): Integer;
152 | procedure rgb2cmyk(R,G,B: Byte; out C,M,Y,K: Byte);
153 | procedure cmyk2rgb(C,M,Y,K: Byte; out R,G,B: Byte);
154 | procedure rgb2yuv(R,G,B: Byte; out Y,U,V: Byte);
155 |
156 | procedure Unrle_AMI(Src: TStream; Dest: TStream; packedSize: Integer);
157 | procedure Unrle_GG(Src: TStream; Dest: TStream; packedSize: Integer);
158 | procedure Unrle_PAC(Src: TStream; Dest: TStream; idByte, packByte, specialByte: Byte);
159 | procedure UnRle_PGC(src: TStream; dest: TStream; packedSize: Integer);
160 | procedure UnRle_CPR(src: TStream; dest: TStream; packedSize: Integer);
161 |
162 | procedure Unrle_TGA(Src: TStream; Dest: TStream; packedSize: Integer; unitSize: Integer);
163 | procedure Unrle_RGB(Src: TStream; Dest: TStream; packedSize: Integer);
164 | procedure Unrle_PCX(Src: TStream; Dest: TStream; packedSize: Integer);
165 | procedure Unrle_CUT(Src: TStream; Dest: TStream; packedSize: Integer; unitSize: Integer);
166 | procedure Unrle_DLP(Src: TStream; Dest: TStream; packedSize: Integer; escapeByte: Byte);
167 | procedure Unrle_PSD(Src: TStream; Dest: TStream; packedSize: Integer; unitSize: Integer = 1); //psd,mac
168 | procedure UnRle_LBM(Src: TStream; Dest: TStream; packedSize: Integer);
169 |
170 | {
171 | procedure UnRleBMP8(source: TQFile; out dest: TQFile; packedSize: Integer; width, height: Integer);
172 | procedure UnRle4BT(source: TQFile; out dest: TQFile; packedSize: Integer);
173 | }
174 | function hexInt(hex: String): Integer;
175 |
176 | var BitmapFormats: TPV_BitmapFormat;
177 |
178 | implementation
179 |
180 | uses PV_Grayscale, PV_Palette;
181 |
182 | {$INCLUDE RLE.pas}
183 |
184 | function MakePix(R, G, B, A: Byte): TPix;
185 | begin
186 | Result.RGBA := B + (G shl 8) + (R shl 16) + (A shl 24);
187 | end;
188 |
189 | function Clip(V: Extended): Byte;
190 | begin
191 | if V > 255 then Result := 255
192 | else if V < 0 then Result := 0
193 | else Result := Round(V);
194 | end;
195 |
196 | function SamePix(P, R: TPix; Threshold: Byte): Boolean;
197 | begin
198 | Result := False;
199 |
200 | if abs(P.R - R.R) > Threshold then Exit;
201 | if abs(P.G - R.G) > Threshold then Exit;
202 | if abs(P.B - R.B) > Threshold then Exit;
203 |
204 | Result := True;
205 | end;
206 |
207 | function Limit(Min, Max, Val: Integer): Integer;
208 | begin
209 | if Val < Min then Exit(Min);
210 | if Val > Max then Exit(Max);
211 | Exit(Val);
212 | end;
213 |
214 | procedure rgb2yuv(R,G,B: Byte; out Y,U,V: Byte);
215 | var YY, UU, VV: Extended;
216 | begin
217 | YY := +0.2990 * R + 0.5870 * G + 0.1140 * B;
218 | UU := 128 -0.1687 * R - 0.3313 * G + 0.5000 * B;
219 | VV := 128 +0.5000 * R - 0.4187 * G - 0.0813 * B;
220 |
221 | Y := floor(YY);
222 | V := floor(VV);
223 | U := floor(UU);
224 | end;
225 |
226 | procedure lab2rgb(L1,A1,B1: Byte; out R,G,B: Byte);
227 | var LL,AA,BBB: Extended;
228 | Y,X,Z: Extended;
229 | Y3,X3,Z3: Extended;
230 | RR,GG,BB: Extended;
231 | begin
232 | //http://www.easyrgb.com/
233 | LL := L1 / 2.55;
234 | AA := A1 - 128;
235 | BBB := B1 - 128;
236 |
237 | //CIELAB -> XYZ
238 | Y := (LL + 16 ) / 116;
239 | X := AA / 500 + Y;
240 | Z := Y - BBB / 200;
241 |
242 | Y3 := power(Y,3);
243 | X3 := power(X,3);
244 | Z3 := power(Z,3);
245 |
246 | if ( Y3 > 0.008856 ) then Y := Y3
247 | else Y := ( Y - 16 / 116 ) / 7.787;
248 | if ( X3 > 0.008856 ) then X := X3
249 | else X := ( X - 16 / 116 ) / 7.787;
250 | if ( Z3 > 0.008856 ) then Z := Z3
251 | else Z := ( Z - 16 / 116 ) / 7.787;
252 |
253 | X := 95.047 * X;
254 | Y := 100.000 * Y;
255 | Z := 108.883 * Z;
256 |
257 | //XYZ -> RGB
258 | X := X / 100;
259 | Y := Y / 100;
260 | Z := Z / 100;
261 |
262 | rr := X * 3.2406 + Y * -1.5372 + Z * -0.4986;
263 | gg := X * -0.9689 + Y * 1.8758 + Z * 0.0415;
264 | bb := X * 0.0557 + Y * -0.2040 + Z * 1.0570;
265 |
266 | if ( rr > 0.0031308 ) then rr := 1.055 * power(rr, 1 / 2.4 ) - 0.055
267 | else rr := 12.92 * rr;
268 | if ( gg > 0.0031308 ) then gg := 1.055 * power(gg, 1 / 2.4 ) - 0.055
269 | else gg := 12.92 * gg;
270 | if ( bb > 0.0031308 ) then bb := 1.055 * power(bb, 1 / 2.4 ) - 0.055
271 | else bb := 12.92 * bb;
272 |
273 | rr := rr * 255;
274 | gg := gg * 255;
275 | bb := bb * 255;
276 |
277 | r := clip(rr);
278 | g := clip(gg);
279 | b := clip(bb);
280 | end;
281 |
282 | procedure rgb2cmyk(R,G,B: Byte; out C,M,Y,K: Byte);
283 | var RR,GG,BB,KK: Extended;
284 | Temp: Extended;
285 | begin
286 | RR := R/255;
287 | GG := G/255;
288 | BB := B/255;
289 |
290 | KK := 1-max(RR,max(GG,BB));
291 | Temp := 1-KK;
292 | if Temp = 0 then Temp := 0.01;
293 |
294 | C := Round(100*(1-RR-KK) / Temp);
295 | M := Round(100*(1-GG-KK) / Temp);
296 | Y := Round(100*(1-BB-KK) / Temp);
297 |
298 | if C>100 then C := 100;
299 | if M>100 then M := 100;
300 | if Y>100 then Y := 100;
301 |
302 | K := Round(100*KK);
303 | if K>100 then K := 100;
304 | end;
305 |
306 |
307 | procedure cmyk2rgb(C, M, Y, K: Byte; out R, G, B: Byte);
308 | var Temp: Extended;
309 | CC,MM,YY,KK: Extended;
310 | begin
311 | CC := C/100;
312 | MM := M/100;
313 | YY := Y/100;
314 | KK := K/100;
315 |
316 | Temp := (1-KK);
317 |
318 | R := Clip(255* (1-CC) * Temp);
319 | G := Clip(255* (1-MM) * Temp);
320 | B := Clip(255* (1-YY) * Temp);
321 | end;
322 |
323 | procedure TPV_Bitmap.Draw(Bitmap: TPV_Bitmap; Left,Top, AWidth,AHeight: Integer);
324 | begin
325 | //FBitmap.Canvas.StretchDraw(Rect(Left,Top, Left+AWidth, Top+AHeight), Bitmap.FBitmap);
326 | //TODO
327 | end;
328 |
329 | procedure TPV_Bitmap.FlipV;
330 | var Old: TPV_Bitmap;
331 | y: Integer;
332 | begin
333 | Old := TPV_Bitmap.Create;
334 | Old.CopyFrom(Self);
335 |
336 | for y:=0 to FHeight-1 do begin
337 | Move(Old.Scanline[FHeight-y-1]^, Self.Scanline[y]^, FWidth*4);
338 | end;
339 |
340 | Old.Free;
341 | end;
342 |
343 | procedure TPV_Bitmap.FlipH;
344 | var Old: TPV_Bitmap;
345 | x,y: Integer;
346 | begin
347 | Old := TPV_Bitmap.Create;
348 | Old.CopyFrom(Self);
349 |
350 | for y:=0 to FHeight-1 do
351 | for x:=0 to FWidth-1 do begin
352 | Self[x,y] := Old[FWidth-x-1,y];
353 | end;
354 |
355 | Old.Free;
356 | end;
357 |
358 | procedure TPV_Bitmap.CopyFrom(Bitmap: TPV_Bitmap);
359 | var x,y: Integer;
360 | begin
361 | SetSize(Bitmap.Width, Bitmap.Height);
362 |
363 | for y:=0 to Height-1 do
364 | Move(Bitmap.Scanline[y]^, Self.Scanline[y]^, 4*Bitmap.Width);
365 | end;
366 |
367 | {$IFDEF WINDOWS}
368 | procedure TPV_Bitmap.CopyFrom(Bitmap: TBitmap);
369 | var x,y: Integer;
370 | R: TPix;
371 | Bpp: TPixelFormat;
372 | P: PByteArray;
373 | begin
374 | SetSize(Bitmap.Width, Bitmap.Height);
375 |
376 | Bpp := Bitmap.PixelFormat;
377 |
378 | for y:=0 to Bitmap.Height-1 do begin
379 | P := Bitmap.Scanline[y];
380 |
381 | case Bpp of
382 | pf32bit: for x:=0 to Bitmap.Width-1 do
383 | Self.SetRGBA(x,y, P^[4*x+2], P^[4*x+1], P^[4*x], P^[4*x+3]);
384 |
385 | pf24bit: for x:=0 to Bitmap.Width-1 do
386 | Self.SetRGB(x,y, P^[3*x+2], P^[3*x+1], P^[3*x]);
387 | end;
388 | end;
389 | end;
390 | {$ELSE}
391 | procedure TPV_Bitmap.CopyFrom(Bitmap: TBitmap);
392 | var x,y: Integer;
393 | R: TPix;
394 | Bpp: TPixelFormat;
395 | P: PByteArray;
396 | begin
397 | SetSize(Bitmap.Width, Bitmap.Height);
398 |
399 | Bpp := Bitmap.PixelFormat;
400 |
401 | for y:=0 to Bitmap.Height-1 do begin
402 | P := Bitmap.Scanline[y];
403 |
404 | case Bpp of
405 | pf32bit: for x:=0 to Bitmap.Width-1 do
406 | Self.SetRGBA(x,y, P^[4*x+2], P^[4*x+1], P^[4*x], P^[4*x+3]);
407 |
408 | pf24bit: for x:=0 to Bitmap.Width-1 do
409 | Self.SetRGB(x,y, P^[3*x+2], P^[3*x+1], P^[3*x]);
410 | end;
411 | end;
412 | end;
413 | {$ENDIF}
414 |
415 | procedure TPV_Bitmap.CopyFrom(Bitmap: TFPMemoryImage);
416 | var x,y: Integer;
417 | Col: TFPColor;
418 | P: TPix;
419 | begin
420 | SetSize(Bitmap.Width, Bitmap.Height);
421 |
422 | for y:=0 to Bitmap.Height-1 do
423 | for x:=0 to Bitmap.Width-1 do begin
424 | {if Bitmap.UsePalette then
425 | Col := Bitmap.Palette[Bitmap.Palette[x, y]]
426 | else }
427 | Col := Bitmap.Colors[x, y];
428 |
429 |
430 | P.R := Col.Red shr 8;
431 | P.G := Col.Green shr 8;
432 | P.B := Col.Blue shr 8;
433 | P.A := Col.Alpha shr 8;
434 |
435 | Self.SetRGBA(x,y, P.R, P.G, P.B, P.A);
436 | end;
437 | end;
438 |
439 | procedure TPV_Bitmap.ReduceColors(MaxColors: Byte; Dither: TDither);
440 | begin
441 | PV_Palette.ReduceColors(Self, MaxColors, Dither);
442 | end;
443 |
444 | procedure TPV_Bitmap.Grayscale(MaxColors: Byte; Dither: TDither);
445 | begin
446 | PV_Grayscale.Grayscale(Self, MaxColors, Dither);
447 | end;
448 |
449 | procedure TPV_Bitmap.BlackWhite(Dither: TDither);
450 | begin
451 | PV_Grayscale.BlackWhite(Self, Dither);
452 | end;
453 |
454 | procedure TPV_Bitmap.Highcolor(Bits: Integer);
455 | var x,y: Integer;
456 | P: TPix;
457 | begin
458 | if Bits = 15 then begin
459 | for y:=0 to FHeight-1 do
460 | for x:=0 to FWidth-1 do begin
461 | P := Self[x,y];
462 |
463 | P.R := Byte(P.R shr 3) shl 3;
464 | P.G := Byte(P.G shr 3) shl 3;
465 | P.B := Byte(P.B shr 3) shl 3;
466 |
467 | Self.SetRGBA(x,y, P.R, P.G, P.B, P.A);
468 | end;
469 |
470 | end
471 | else begin
472 | for y:=0 to FHeight-1 do
473 | for x:=0 to FWidth-1 do begin
474 | P := Self[x,y];
475 |
476 | P.R := Byte(P.R shr 3) shl 3;
477 | P.G := Byte(P.G shr 2) shl 2;
478 | P.B := Byte(P.B shr 3) shl 3;
479 |
480 | Self.SetRGBA(x,y, P.R, P.G, P.B, P.A);
481 | end;
482 |
483 | end;
484 | end;
485 |
486 | procedure TPV_Bitmap.Resize(AWidth, AHeight: Integer);
487 | var Tmp,Tmp2: TBitmap;
488 | begin
489 | Tmp := Self.ToBitmap;
490 |
491 | Tmp2 := TBitmap.Create;
492 | Tmp2.PixelFormat := pf32bit;
493 | Tmp2.SetSize(AWidth, AHeight);
494 |
495 | Tmp2.Canvas.StretchDraw(Rect(0,0, AWidth, AHeight), Tmp);
496 | Tmp.Free;
497 |
498 | CopyFrom(Tmp2);
499 | Tmp2.Free;
500 | end;
501 |
502 | procedure TPV_Bitmap.ResizePercent(AWidth, AHeight: Integer);
503 | begin
504 | Resize(Round(AWidth * FWidth/100), Round(AHeight * FHeight/100));
505 | end;
506 |
507 | procedure TPV_Bitmap.RemoveAlpha;
508 | var x,y: Integer;
509 | P: TPix;
510 | begin
511 | for y:=0 to FHeight-1 do
512 | for x:=0 to FWidth-1 do begin
513 | P := Self[x,y];
514 | P.A := 255;
515 |
516 | Self.SetRGB(x,y, P.R,P.G,P.B);
517 | end;
518 | end;
519 |
520 | procedure TPV_Bitmap.Opaque;
521 | var x,y: Integer;
522 | P: TPix;
523 | A,A2: Extended;
524 | BG: TPix;
525 | begin
526 | Bg := MakePix(255,255,255,255);
527 |
528 | for y:=0 to FHeight-1 do
529 | for x:=0 to FWidth-1 do begin
530 | P := Self[x,y];
531 | A := P.A/255;
532 | A2 := 1-A;
533 |
534 | P.R := Clip(P.R * A + BG.R * A2);
535 | P.G := Clip(P.G * A + BG.G * A2);
536 | P.B := Clip(P.B * A + BG.B * A2);
537 |
538 | Self.SetRGB(x,y, P.R,P.G,P.B);
539 | end;
540 | end;
541 |
542 | {$IFDEF WINDOWS}
543 | function TPV_Bitmap.ToBitmap: TBitmap;
544 | var x,y: Integer;
545 | P,R: PPixArray;
546 | begin
547 | Result := TBitmap.Create;
548 | Result.PixelFormat := pf32bit;
549 | Result.SetSize(FWidth, FHeight);
550 |
551 | for y:=0 to FHeight-1 do begin
552 | P := Result.Scanline[y];
553 | R := Scanline[y];
554 |
555 | for x:=0 to FWidth-1 do begin
556 | P^[x].RGBA := R^[x].RGBA;
557 | end;
558 | end;
559 | end;
560 | {$ELSE}
561 | function TPV_Bitmap.ToBitmap: TBitmap;
562 | var x,y: Integer;
563 | R: PPixArray;
564 | Color: TColor;
565 | begin
566 | Result := TBitmap.Create;
567 | Result.PixelFormat := pf32bit;
568 | Result.SetSize(FWidth, FHeight);
569 |
570 | for y:=0 to FHeight-1 do begin
571 | R := Scanline[y];
572 |
573 | for x:=0 to FWidth-1 do begin
574 | Color := R^[x].R + (R^[x].G shl 8) + (R^[x].B shl 16);
575 | Result.Canvas.Pixels[x,y] := Color;
576 | end;
577 | end;
578 | end;
579 | {$ENDIF}
580 |
581 | {$IFDEF WINDOWS}
582 | function TPV_Bitmap.GetPiece(AX, AY, AWidth, AHeight: Integer): TBitmap;
583 | var x,y: Integer;
584 | P,R: PPixArray;
585 | begin
586 | Result := TBitmap.Create;
587 | Result.PixelFormat := pf32bit;
588 | Result.SetSize(AWidth, AHeight);
589 |
590 | AWidth := Min(Width, AWidth);
591 | AHeight := Min(Height, AHeight);
592 |
593 | for y:=0 to AHeight-1 do begin
594 | P := Result.Scanline[y];
595 | R := Scanline[AY+y];
596 |
597 | for x:=0 to AWidth-1 do begin
598 | P^[x].RGBA := R^[AX+x].RGBA;
599 | end;
600 | end;
601 | end;
602 | {$ELSE}
603 | function TPV_Bitmap.GetPiece(AX, AY, AWidth, AHeight: Integer): TBitmap;
604 | var x,y: Integer;
605 | P: PByteArray;
606 | R: PPixArray;
607 | Color: TColor;
608 | begin
609 | Result := TBitmap.Create;
610 | Result.PixelFormat := pf24bit;
611 | Result.SetSize(AWidth, AHeight);
612 |
613 | AWidth := Min(Width, AWidth);
614 | AHeight := Min(Height, AHeight);
615 |
616 | for y:=0 to AHeight-1 do begin
617 | R := Scanline[AY+y];
618 |
619 | for x:=0 to AWidth-1 do begin
620 | Color := R^[AX+x].R + (R^[AX+x].G shl 8) + (R^[AX+x].B shl 16);
621 | Result.Canvas.Pixels[x,y] := Color;
622 | end;
623 | end;
624 | end;
625 | {$ENDIF}
626 |
627 | procedure TPV_Bitmap.DrawTo(X,Y: Integer; Canvas: TCanvas);
628 | var Bmp: TBitmap;
629 | begin
630 | Bmp := Self.ToBitmap;
631 | Canvas.Draw(X, Y, Bmp);
632 | Bmp.Free;
633 | end;
634 |
635 | procedure TPV_Bitmap.DrawTo(Dest: TRect; Canvas: TCanvas);
636 | var Bmp: TBitmap;
637 | begin
638 | Bmp := Self.ToBitmap;
639 | Canvas.StretchDraw(Dest, Bmp);
640 | Bmp.Free;
641 | end;
642 |
643 | procedure TPV_Bitmap.Trim(RR, GG, BB: Byte);
644 | var L,T,R,B: Integer;
645 | P: TPix;
646 | Tmp: TBitmap;
647 |
648 | procedure LeftMargin;
649 | var x,y: Integer;
650 | begin
651 | L := FWidth-1;
652 |
653 | for y:=0 to FHeight-1 do
654 | for x:=0 to FWidth-1 do begin
655 | P := Self[x,y];
656 |
657 | if (P.R <> 255) or (P.G <> 255) or (P.B <> 255) then begin
658 | L := Min(x, L);
659 | break;
660 | end;
661 | end;
662 | end;
663 | procedure RightMargin;
664 | var x,y: Integer;
665 | begin
666 | R := 0;
667 |
668 | for y:=0 to FHeight-1 do
669 | for x:=FWidth-1 downto 0 do begin
670 | P := Self[x,y];
671 |
672 | if (P.R <> 255) or (P.G <> 255) or (P.B <> 255) then begin
673 | R := Max(x, R);
674 | end;
675 | end;
676 | end;
677 | procedure TopMargin;
678 | var x,y: Integer;
679 | begin
680 | T := FHeight-1;
681 |
682 | for x:=0 to FWidth-1 do
683 | for y:=0 to FHeight-1 do begin
684 | P := Self[x,y];
685 |
686 | if (P.R <> 255) or (P.G <> 255) or (P.B <> 255) then begin
687 | T := Min(y, T);
688 | end;
689 | end;
690 | end;
691 | procedure BottomMargin;
692 | var x,y: Integer;
693 | begin
694 | B := 0;
695 |
696 | for x:=0 to FWidth-1 do
697 | for y:=FHeight-1 downto 0 do begin
698 | P := Self[x,y];
699 |
700 | if (P.R <> 255) or (P.G <> 255) or (P.B <> 255) then begin
701 | B := Max(y, B);
702 | end;
703 | end;
704 | end;
705 | begin
706 | LeftMargin;
707 | RightMargin;
708 | BottomMargin;
709 | TopMargin;
710 |
711 | Tmp := Self.GetPiece(L, T, R-L, B-T);
712 | Self.CopyFrom(Tmp);
713 | Tmp.Free;
714 | end;
715 |
716 | function TPV_Bitmap.CountColors: Integer;
717 | var Map: array of array of array of Byte;
718 | x,y: Integer;
719 | P: TPix;
720 | i,j,k: Integer;
721 | begin
722 | SetLength(Map, 256,256,256); //16 MB
723 |
724 | for i:=0 to 255 do
725 | for j:=0 to 255 do
726 | for k:=0 to 255 do Map[i][j][k] := 0;
727 |
728 |
729 | for y:=0 to FHeight-1 do
730 | for x:=0 to FWidth-1 do begin
731 | P := Self.Pixel[x,y];
732 |
733 | Map[P.R][P.G][P.B] := 1;
734 | end;
735 |
736 | Result := 0;
737 |
738 | for i:=0 to 255 do
739 | for j:=0 to 255 do
740 | for k:=0 to 255 do if Map[i][j][k] <> 0 then Inc(Result);
741 | end;
742 |
743 | function TPV_Bitmap.GetPixel(X,Y: Integer): TPix;
744 | var P: PPixArray;
745 | begin
746 | P := Scanline[Y];
747 | Result := P^[X];
748 | end;
749 |
750 | procedure TPV_Bitmap.SetPixel(X,Y: Integer; Val: TPix);
751 | var P: PPixArray;
752 | begin
753 | P := Scanline[Y];
754 | P^[X] := Val;
755 | end;
756 |
757 | function TPV_Bitmap.GetWidth: Integer;
758 | begin
759 | Result := FWidth;
760 | end;
761 |
762 | procedure TPV_Bitmap.SetWidth(Val: Integer);
763 | begin
764 | FWidth := Val;
765 | SetLength(FData, FWidth*FHeight);
766 | end;
767 |
768 | function TPV_Bitmap.GetHeight: Integer;
769 | begin
770 | Result := FHeight;
771 | end;
772 |
773 | procedure TPV_Bitmap.SetHeight(Val: Integer);
774 | begin
775 | FHeight := Val;
776 | SetLength(FData, FWidth*FHeight);
777 | end;
778 |
779 | function TPV_Bitmap.GetScanline(Y: Integer): Pointer;
780 | begin
781 | Result := @FData[Y* FWidth];
782 | end;
783 |
784 | procedure TPV_Bitmap.SetMono(X, Y: Integer; B: Byte);
785 | begin
786 | FData[Y* FWidth + X].RGBA := PaletteMono[B];
787 | end;
788 |
789 | {$IFDEF WINDOWS}
790 | procedure TPV_Bitmap.SetRGBA(X, Y: Integer; R, G, B, A: Byte);
791 | begin
792 | FData[Y* FWidth + X].RGBA := B + (G shl 8) + (R shl 16) + (A shl 24);
793 | end;
794 |
795 | procedure TPV_Bitmap.SetRGB(X, Y: Integer; R, G, B: Byte);
796 | begin
797 | FData[Y* FWidth + X].RGBA := B + (G shl 8) + (R shl 16) + (255 shl 24);
798 | end;
799 |
800 | {$ELSE}
801 | procedure TPV_Bitmap.SetRGBA(X, Y: Integer; R, G, B, A: Byte);
802 | begin
803 | FData[Y* FWidth + X].R := R;
804 | FData[Y* FWidth + X].G := G;
805 | FData[Y* FWidth + X].B := B;
806 | FData[Y* FWidth + X].A := A;
807 | end;
808 |
809 | procedure TPV_Bitmap.SetRGB(X, Y: Integer; R, G, B: Byte);
810 | begin
811 | FData[Y* FWidth + X].R := R;
812 | FData[Y* FWidth + X].G := G;
813 | FData[Y* FWidth + X].B := B;
814 | FData[Y* FWidth + X].A := 255;
815 | end;
816 | {$ENDIF}
817 |
818 | procedure TPV_Bitmap.Set32(X, Y: Integer; Val: Cardinal);
819 | begin
820 | FData[Y* FWidth + X].RGBA := Val;
821 | end;
822 |
823 | procedure TPV_Bitmap.Set32(X, Y: Integer; Val: TPal);
824 | begin
825 | FData[Y* FWidth + X].RGBA := Val.B + (Val.G shl 8) + (Val.R shl 16) + (255 shl 24);
826 | end;
827 |
828 | procedure TPV_Bitmap.SetR(X, Y: Integer; R: Byte);
829 | begin
830 | FData[Y* FWidth + X].R := R;
831 | end;
832 |
833 | procedure TPV_Bitmap.SetG(X, Y: Integer; G: Byte);
834 | begin
835 | FData[Y* FWidth + X].G := G;
836 | end;
837 |
838 | procedure TPV_Bitmap.SetB(X, Y: Integer; B: Byte);
839 | begin
840 | FData[Y* FWidth + X].B := B;
841 | end;
842 |
843 | procedure TPV_Bitmap.SetA(X, Y: Integer; A: Byte);
844 | begin
845 | FData[Y* FWidth + X].A := A;
846 | end;
847 |
848 | procedure TPV_Bitmap.AddPal(R, G, B, A: Byte);
849 | begin
850 | FPalette[PaletteLen].RGBA := B + (G shl 8) + (R shl 16) + (A shl 24);
851 | Inc(PaletteLen);
852 | end;
853 |
854 | procedure TPV_Bitmap.SetPal(X, Y: Integer; Index: Byte);
855 | begin
856 | FData[Y* FWidth + X].RGBA := FPalette[Index].RGBA;
857 | end;
858 |
859 | function TPV_Bitmap.GetPalIndex(X, Y: Integer): Integer;
860 | var P,Pal: TPix;
861 | i: Integer;
862 | begin
863 | P := Self.Pixel[x,y];
864 |
865 | for i:=0 to PaletteLen-1 do begin
866 | Pal := FPalette[i];
867 |
868 | if (Pal.R = P.R) and (Pal.G = P.G) and (Pal.B = P.B) then Exit(i);
869 | end;
870 |
871 | Result := 0;
872 | end;
873 |
874 | procedure TPV_Bitmap.AddPalette(Pal: array of TPal; Len: Integer);
875 | var i: Integer;
876 | begin
877 | for i:=0 to Len-1 do
878 | AddPal(Pal[i].R, Pal[i].G, Pal[i].B, 255);
879 | end;
880 |
881 | procedure TPV_Bitmap.ClearPalette;
882 | begin
883 | PaletteLen := 0;
884 | end;
885 |
886 | constructor TPV_Bitmap.Create;
887 | begin
888 | inherited Create;
889 |
890 | FWidth := 1;
891 | FHeight := 1;
892 | SetLength(FData, FWidth*FHeight);
893 |
894 | SetLength(FPalette, 256);
895 | PaletteLen := 0;
896 | FormatName := '';
897 | end;
898 |
899 | procedure TPV_Bitmap.SetSize(AWidth, AHeight: Integer);
900 | begin
901 | FWidth := AWidth;
902 | FHeight := AHeight;
903 | SetLength(FData, FWidth*FHeight);
904 | end;
905 |
906 | function TPV_Bitmap.LoadFromFile(Filename: String): Boolean;
907 | var Pic: TPicture;
908 | Reader: TPV_BitmapReader;
909 | F: TFileStream;
910 | Ext: String;
911 | Res: Boolean;
912 | AFormat: String;
913 | begin
914 | Result := False;
915 | Ext := Copy(ExtractFileExt(Filename), 2);
916 |
917 | F := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone);
918 |
919 | if F.Size < 50 then begin
920 | F.Free;
921 | Exit;
922 | end;
923 |
924 | Reader := BitmapFormats.FindReader(Ext, AFormat);
925 |
926 | if Reader <> nil then begin
927 | ClearPalette;
928 | Res := Reader(Self, F);
929 | if Res then begin
930 | Result := True;
931 | Self.FormatName := AFormat;
932 | end;
933 | end;
934 |
935 | F.Free;
936 | end;
937 |
938 | procedure TPV_Bitmap.SaveToFile(Filename: String);
939 | begin
940 | SaveToFile(Filename, 0);
941 | end;
942 |
943 | procedure TPV_Bitmap.SaveToFile(Filename: String; Compression: Byte);
944 | var Ext: String;
945 | Writer: TPV_BitmapWriter;
946 | F: TFileStream;
947 | begin
948 | Ext := Copy(ExtractFileExt(Filename), 2);
949 |
950 | F := TFileStream.Create(Filename, fmCreate);
951 |
952 | Writer := BitmapFormats.FindWriter(Ext);
953 |
954 | if Writer <> nil then Writer(Self, F, Compression)
955 | else raise Exception.Create('Unsupported format: ' + Ext);
956 |
957 | F.Free;
958 | end;
959 |
960 | procedure TPV_BitmapFormat.Item(Index: Integer; out Ext,Name: String; out
961 | Reader: TPV_BitmapReader; out Writer: TPV_BitmapWriter);
962 | begin
963 | Ext := FList[Index].Ext;
964 | Name := FList[Index].Name;
965 | Reader := FList[Index].Reader;
966 | Writer := FList[Index].Writer;
967 | end;
968 |
969 | constructor TPV_BitmapFormat.Create;
970 | begin
971 | FCount := 0;
972 | SetLength(FList, 200);
973 | end;
974 |
975 | function TPV_BitmapFormat.FindReader(Ext: String; out Format: String): TPV_BitmapReader;
976 | var i: Integer;
977 | begin
978 | Result := nil;
979 |
980 | Ext := LowerCase(Ext);
981 |
982 | for i:=0 to FCount-1 do
983 | if FList[i].Ext = Ext then begin
984 | Format := FList[i].Name;
985 | Result := FList[i].Reader;
986 | Exit;
987 | end;
988 | end;
989 |
990 | function TPV_BitmapFormat.FindWriter(Ext: String): TPV_BitmapWriter;
991 | var i: Integer;
992 | begin
993 | Result := nil;
994 |
995 | Ext := LowerCase(Ext);
996 |
997 | for i:=0 to FCount-1 do
998 | if FList[i].Ext = Ext then Exit(FList[i].Writer);
999 | end;
1000 |
1001 | function TPV_BitmapFormat.FindName(Ext: String): String;
1002 | var i: Integer;
1003 | begin
1004 | Result := '';
1005 |
1006 | Ext := LowerCase(Ext);
1007 |
1008 | for i:=0 to FCount-1 do
1009 | if FList[i].Ext = Ext then Exit(FList[i].Name);
1010 | end;
1011 |
1012 | procedure TPV_BitmapFormat.Add(Ext: String; Reader: TPV_BitmapReader;
1013 | Writer: TPV_BitmapWriter; Name: String);
1014 | begin
1015 | FList[FCount].Ext := Ext;
1016 | FList[FCount].Reader := Reader;
1017 | FList[FCount].Writer := Writer;
1018 | FList[FCount].Name := Name;
1019 | Inc(FCount);
1020 | end;
1021 |
1022 | initialization
1023 | BitmapFormats := TPV_BitmapFormat.Create;
1024 |
1025 | finalization
1026 | BitmapFormats.Free;
1027 |
1028 | end.
1029 |
--------------------------------------------------------------------------------
/PV_CRC32Stream.pas:
--------------------------------------------------------------------------------
1 | unit PV_CRC32Stream;
2 |
3 | //Lazzy Image Viewer
4 | //github.com/PascalVault
5 | //License: MIT
6 |
7 | interface
8 |
9 | uses Classes;
10 |
11 | type
12 |
13 | { TPV_CRC32Stream }
14 |
15 | TPV_CRC32Stream = class(TStream)
16 | private
17 | FHash: Cardinal;
18 | FStream: TStream;
19 | public
20 | constructor Create(Str: TStream);
21 | function Write(const Buffer; Count: Longint): Longint; override;
22 | function Final: Cardinal;
23 | procedure Clear;
24 | end;
25 |
26 | var Table: array[0..255] of LongInt = (
27 | $00000000, $77073096, $EE0E612C, $990951BA, $076DC419, $706AF48F, $E963A535, $9E6495A3,
28 | $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
29 | $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
30 | $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
31 | $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
32 | $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
33 | $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
34 | $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
35 | $76DC4190, $01DB7106, $98D220BC, $EFD5102A, $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
36 | $7807C9A2, $0F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
37 | $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
38 | $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
39 | $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
40 | $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
41 | $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F,
42 | $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
43 | $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $04DB2615, $73DC1683,
44 | $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
45 | $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7,
46 | $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
47 | $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
48 | $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
49 | $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F,
50 | $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
51 | $9B64C2B0, $EC63F226, $756AA39C, $026D930A, $9C0906A9, $EB0E363F, $72076785, $05005713,
52 | $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
53 | $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
54 | $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
55 | $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB,
56 | $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
57 | $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF,
58 | $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D
59 | );
60 |
61 | implementation
62 |
63 | constructor TPV_CRC32Stream.Create(Str: TStream);
64 | begin
65 | inherited Create;
66 | Clear;
67 | FStream := Str;
68 | end;
69 |
70 | function TPV_CRC32Stream.Write(const Buffer; Count: Longint): Longint;
71 | var i: Integer;
72 | B: PByte;
73 | begin
74 | FStream.Write(Buffer, Count);
75 |
76 | B := @Buffer;
77 |
78 | for i:=0 to Count-1 do begin
79 | FHash := (FHash shr 8) xor Table[byte(FHash) xor B^];
80 | Inc(B);
81 | end;
82 | end;
83 |
84 | function TPV_CRC32Stream.Final: Cardinal;
85 | begin
86 | Result:= FHash xor $FFFFFFFF;
87 | end;
88 |
89 | procedure TPV_CRC32Stream.Clear;
90 | begin
91 | FHash := $FFFFFFFF;
92 | end;
93 |
94 | end.
95 |
--------------------------------------------------------------------------------
/PV_Filters.pas:
--------------------------------------------------------------------------------
1 | unit PV_Filters;
2 |
3 | //Lazzy Image Viewer
4 | //github.com/PascalVault
5 | //License: MIT
6 |
7 | interface
8 |
9 | uses Math, PV_Bitmap;
10 |
11 | // Resampling ------------------------------------------------------------------
12 | // Based on Bitmap Resampler by Anders Melander (15-03-1998), which was based on
13 | // filter.c by Dale Schumacher (published in Graphics Gems III, p. 8-16), with
14 | // improvements by David Ullrich.
15 |
16 | type
17 | TResampleFilter = (rfBox, rfBilinear, rfHermite, rfBell, rfSpline, rfLanczos3, rfMitchell);
18 |
19 | { TPV_Bitmap }
20 |
21 | TPV_Bitmap = class(PV_Bitmap.TPV_Bitmap)
22 | public
23 | procedure Convolution(Kernel: array of Double; Size: Byte; Divider: Integer=1);
24 |
25 | procedure Rotate90;
26 | procedure Rotate180;
27 | procedure Rotate270;
28 |
29 | procedure AddNoise(Amount: Byte);
30 | procedure DeNoise;
31 | procedure SmarterBlur;
32 |
33 | procedure Brightness(Amount: Byte);
34 | procedure Contrast(Amount: Extended);
35 | procedure FindEdges;
36 | procedure FindEdges2;
37 | procedure FindEdges3;
38 |
39 | procedure Negate;
40 | procedure Gamma(Amount: Extended);
41 |
42 | procedure Sharpen;
43 | procedure Emboss;
44 | procedure BoxBlur;
45 | procedure GaussBlur;
46 | procedure GaussBlur5;
47 | procedure Unsharp;
48 | procedure Sepia(Amount: Byte = 30);
49 |
50 | function ResampleTo(DstWidth, DstHeight: Integer; Filter: TResampleFilter): TPV_Bitmap;
51 | procedure Resample(AWidth, AHeight: Integer; Filter: TResampleFilter);
52 | procedure ResamplePercent(AWidth, AHeight: Integer; Filter: TResampleFilter);
53 |
54 | procedure BGR;
55 | procedure BRG;
56 | procedure GBR;
57 | procedure GRB;
58 | procedure RBG;
59 |
60 | procedure ExtractRed;
61 | procedure ExtractGreen;
62 | procedure ExtractBlue;
63 | procedure ExtractAlpha;
64 |
65 | procedure ExtractCyan;
66 | procedure ExtractMagenta;
67 | procedure ExtractYellow;
68 | procedure ExtractBlack;
69 | end;
70 |
71 | implementation
72 |
73 | // -----------------------------------------------------------------------------
74 | //
75 | // Filter functions
76 | //
77 | // -----------------------------------------------------------------------------
78 |
79 | // Hermite filter
80 | function HermiteFilter(Value: Single): Single;
81 | begin
82 | // f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1
83 | if (Value < 0.0) then
84 | Value := -Value;
85 | if (Value < 1.0) then
86 | Result := (2.0 * Value - 3.0) * Sqr(Value) + 1.0
87 | else
88 | Result := 0.0;
89 | end;
90 |
91 | // Box filter
92 | // a.k.a. "Nearest Neighbour" filter
93 | function BoxFilter(Value: Single): Single;
94 | begin
95 | if (Value > -0.5) and (Value <= 0.5) then
96 | Result := 1.0
97 | else
98 | Result := 0.0;
99 | end;
100 |
101 | // Triangle filter
102 | // a.k.a. "Linear" or "Bilinear" filter
103 | function TriangleFilter(Value: Single): Single;
104 | begin
105 | if (Value < 0.0) then
106 | Value := -Value;
107 | if (Value < 1.0) then
108 | Result := 1.0 - Value
109 | else
110 | Result := 0.0;
111 | end;
112 |
113 | // Bell filter
114 | function BellFilter(Value: Single): Single;
115 | begin
116 | if (Value < 0.0) then
117 | Value := -Value;
118 | if (Value < 0.5) then
119 | Result := 0.75 - Sqr(Value)
120 | else if (Value < 1.5) then
121 | begin
122 | Value := Value - 1.5;
123 | Result := 0.5 * Sqr(Value);
124 | end else
125 | Result := 0.0;
126 | end;
127 |
128 | // B-spline filter
129 | function SplineFilter(Value: Single): Single;
130 | var
131 | tt : single;
132 | begin
133 | if (Value < 0.0) then
134 | Value := -Value;
135 | if (Value < 1.0) then
136 | begin
137 | tt := Sqr(Value);
138 | Result := 0.5*tt*Value - tt + 2.0 / 3.0;
139 | end else if (Value < 2.0) then
140 | begin
141 | Value := 2.0 - Value;
142 | Result := 1.0/6.0 * Sqr(Value) * Value;
143 | end else
144 | Result := 0.0;
145 | end;
146 |
147 | // Lanczos3 filter
148 | function Lanczos3Filter(Value: Single): Single;
149 | function SinC(Value: Single): Single;
150 | begin
151 | if (Value <> 0.0) then
152 | begin
153 | Value := Value * Pi;
154 | Result := sin(Value) / Value
155 | end else
156 | Result := 1.0;
157 | end;
158 | begin
159 | if (Value < 0.0) then
160 | Value := -Value;
161 | if (Value < 3.0) then
162 | Result := SinC(Value) * SinC(Value / 3.0)
163 | else
164 | Result := 0.0;
165 | end;
166 |
167 | function MitchellFilter(Value: Single): Single;
168 | const
169 | B = (1.0 / 3.0);
170 | C = (1.0 / 3.0);
171 | var
172 | tt : single;
173 | begin
174 | if (Value < 0.0) then
175 | Value := -Value;
176 | tt := Sqr(Value);
177 | if (Value < 1.0) then
178 | begin
179 | Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * tt))
180 | + ((-18.0 + 12.0 * B + 6.0 * C) * tt)
181 | + (6.0 - 2 * B));
182 | Result := Value / 6.0;
183 | end else
184 | if (Value < 2.0) then
185 | begin
186 | Value := (((-1.0 * B - 6.0 * C) * (Value * tt))
187 | + ((6.0 * B + 30.0 * C) * tt)
188 | + ((-12.0 * B - 48.0 * C) * Value)
189 | + (8.0 * B + 24 * C));
190 | Result := Value / 6.0;
191 | end else
192 | Result := 0.0;
193 | end;
194 |
195 | // -----------------------------------------------------------------------------
196 | // Interpolator
197 | // -----------------------------------------------------------------------------
198 | type
199 | TFilterProc = function(Value: Single): Single;
200 | TResamplers = record
201 | Filter: TFilterProc;
202 | Width: Single;
203 | end;
204 |
205 | TRGB = record
206 | R,G,B: Single;
207 | end;
208 |
209 | // Contributor for a pixel
210 | TContributor = record
211 | pixel: integer; // Source pixel
212 | weight: single; // Pixel weight
213 | end;
214 |
215 | TContributorList = array[0..0] of TContributor;
216 | PContributorList = ^TContributorList;
217 |
218 | // List of source pixels contributing to a destination pixel
219 | TCList = record
220 | n: integer;
221 | p: PContributorList;
222 | end;
223 |
224 | TCListList = array[0..0] of TCList;
225 | PCListList = ^TCListList;
226 |
227 | // Physical bitmap scanline (row)
228 | TRGBList = packed array[0..0] of TPix;
229 | PRGBList = ^TRGBList;
230 |
231 | const
232 | ResampleFilters: array[0..6] of TResamplers = (
233 | (Filter: @BoxFilter; Width: 0.5),
234 | (Filter: @TriangleFilter; Width: 1.0),
235 | (Filter: @HermiteFilter; Width: 1.0),
236 | (Filter: @BellFilter; Width: 1.5),
237 | (Filter: @SplineFilter; Width: 2.0),
238 | (Filter: @Lanczos3Filter; Width: 3.0),
239 | (Filter: @MitchellFilter; Width: 2.0)
240 | );
241 |
242 | function TPV_Bitmap.ResampleTo(DstWidth, DstHeight: Integer; Filter: TResampleFilter): TPV_Bitmap;
243 | //Nearest Neighbor and Bilinear are broken
244 | var xscale, yscale : single; // Zoom scale factors
245 | i, j, k : integer; // Loop variables
246 | center : single; // Filter calculation variables
247 | wwidth, fscale, weight: single; // Filter calculation variables
248 | left, right : integer; // Filter calculation variables
249 | n : integer; // Pixel number
250 | Work : TPV_Bitmap;
251 | contrib : PCListList;
252 | rgb : TRGB;
253 | color : TPix;
254 | SrcWidth : Integer;
255 | SrcHeight : integer;
256 | FilterProc : TFilterProc;
257 | fwidth : single;
258 | begin
259 | FilterProc := ResampleFilters[ord(filter)].Filter;
260 | fwidth := ResampleFilters[ord(filter)].Width;
261 |
262 | Result := TPV_Bitmap.Create;
263 | Result.SetSize(DstWidth, DstHeight);
264 |
265 | SrcWidth := Self.Width;
266 | SrcHeight := Self.Height;
267 | if (SrcWidth < 1) or (SrcHeight < 1) then Exit;
268 |
269 | if (SrcWidth = DstWidth) and (SrcHeight = DstHeight) then begin
270 | Result.CopyFrom(Self);
271 | Exit;
272 | end;
273 |
274 |
275 | // Create intermediate image to hold horizontal zoom
276 | Work := TPV_Bitmap.Create;
277 | try
278 | Work.SetSize(DstWidth, SrcHeight);
279 |
280 | // Improvement suggested by David Ullrich:
281 | if (SrcWidth = 1) then
282 | xscale:= DstWidth / SrcWidth
283 | else
284 | xscale:= (DstWidth - 1) / (SrcWidth - 1);
285 | if (SrcHeight = 1) then
286 | yscale:= DstHeight / SrcHeight
287 | else
288 | yscale:= (DstHeight - 1) / (SrcHeight - 1);
289 |
290 | // --------------------------------------------
291 | // Pre-calculate filter contributions for a row
292 | // -----------------------------------------------
293 | GetMem(contrib, DstWidth* sizeof(TCList));
294 | // Horizontal sub-sampling
295 | if (xscale >= 1.0) then
296 | begin
297 | wwidth := fwidth;
298 | fscale := 1.0;
299 | end
300 | else begin
301 | wwidth := fwidth / xscale;
302 | fscale := 1.0 / xscale;
303 | end;
304 |
305 | for i := 0 to DstWidth-1 do
306 | begin
307 | contrib^[i].n := 0;
308 | GetMem(contrib^[i].p, trunc(wwidth * 2.0 + 1) * sizeof(TContributor));
309 | center := i / xscale;
310 | left := floor(center - wwidth);
311 | right := ceil(center + wwidth);
312 | for j := left to right do
313 | begin
314 | weight := FilterProc((center - j) / fscale) / fscale;
315 | if (weight = 0.0) then
316 | continue;
317 | if (j < 0) then
318 | n := -j
319 | else if (j >= SrcWidth) then
320 | n := SrcWidth - j + SrcWidth - 1
321 | else
322 | n := j;
323 | k := contrib^[i].n;
324 | contrib^[i].n := contrib^[i].n + 1;
325 | contrib^[i].p^[k].pixel := n;
326 | contrib^[i].p^[k].weight := weight;
327 | end;
328 | end;
329 |
330 | // ----------------------------------------------------
331 | // Apply filter to sample horizontally from Src to Work
332 | // ----------------------------------------------------
333 | for k := 0 to SrcHeight-1 do
334 | begin
335 | for i := 0 to DstWidth-1 do
336 | begin
337 | rgb.r := 0.0;
338 | rgb.g := 0.0;
339 | rgb.b := 0.0;
340 | for j := 0 to contrib^[i].n-1 do
341 | begin
342 | color := Self.Pixel[contrib^[i].p^[j].pixel, k];
343 | weight := contrib^[i].p^[j].weight;
344 | if (weight = 0.0) then
345 | continue;
346 | rgb.r := rgb.r + color.r * weight;
347 | rgb.g := rgb.g + color.g * weight;
348 | rgb.b := rgb.b + color.b * weight;
349 | end;
350 |
351 | color.r := Clip(rgb.r);
352 | color.g := Clip(rgb.g);
353 | color.b := Clip(rgb.b);
354 |
355 | Work.Pixel[i, k] := color;
356 | end;
357 | end;
358 |
359 | // Free the memory allocated for horizontal filter weights
360 | for i := 0 to DstWidth-1 do
361 | FreeMem(contrib^[i].p);
362 |
363 | FreeMem(contrib);
364 |
365 | // -----------------------------------------------
366 | // Pre-calculate filter contributions for a column
367 | // -----------------------------------------------
368 | GetMem(contrib, DstHeight* sizeof(TCList));
369 |
370 | // Vertical sub-sampling
371 | if (yscale >= 1.0) then
372 | begin
373 | wwidth := fwidth;
374 | fscale := 1.0;
375 | end
376 | else begin
377 | wwidth := fwidth / yscale;
378 | fscale := 1.0 / yscale;
379 | end;
380 |
381 | for i := 0 to DstHeight-1 do
382 | begin
383 | contrib^[i].n := 0;
384 | GetMem(contrib^[i].p, trunc(wwidth * 2.0 + 1) * sizeof(TContributor));
385 | center := i / yscale;
386 | left := floor(center - wwidth);
387 | right := ceil(center + wwidth);
388 | for j := left to right do
389 | begin
390 | weight := FilterProc((center - j) / fscale) / fscale;
391 | if (weight = 0.0) then
392 | continue;
393 | if (j < 0) then
394 | n := -j
395 | else if (j >= SrcHeight) then
396 | n := SrcHeight - j + SrcHeight - 1
397 | else
398 | n := j;
399 | k := contrib^[i].n;
400 | contrib^[i].n := contrib^[i].n + 1;
401 | contrib^[i].p^[k].pixel := n;
402 | contrib^[i].p^[k].weight := weight;
403 | end;
404 | end;
405 |
406 | // --------------------------------------------------
407 | // Apply filter to sample vertically from Work to Dst
408 | // --------------------------------------------------
409 | for k := 0 to DstWidth-1 do
410 | begin
411 | for i := 0 to DstHeight-1 do
412 | begin
413 | rgb.r := 0;
414 | rgb.g := 0;
415 | rgb.b := 0;
416 | // weight := 0.0;
417 | for j := 0 to contrib^[i].n-1 do
418 | begin
419 | color := Work.Pixel[k, contrib^[i].p^[j].pixel];
420 | weight := contrib^[i].p^[j].weight;
421 | if (weight = 0.0) then
422 | continue;
423 | rgb.r := rgb.r + color.r * weight;
424 | rgb.g := rgb.g + color.g * weight;
425 | rgb.b := rgb.b + color.b * weight;
426 | end;
427 |
428 | color.r := Clip(rgb.r);
429 | color.g := Clip(rgb.g);
430 | color.b := Clip(rgb.b);
431 |
432 | Result.Pixel[k, i] := color;
433 | end;
434 | end;
435 |
436 | // Free the memory allocated for vertical filter weights
437 | for i := 0 to DstHeight-1 do
438 | FreeMem(contrib^[i].p);
439 |
440 | FreeMem(contrib);
441 |
442 | finally
443 | Work.Free;
444 | end;
445 | end;
446 |
447 |
448 | procedure TPV_Bitmap.Rotate90;
449 | var x,y: Integer;
450 | P: TPix;
451 | Tmp: TPV_Bitmap;
452 | begin
453 | Tmp := TPV_Bitmap.Create;
454 | Tmp.SetSize(Height, Width);
455 |
456 | for y:=0 to Height-1 do
457 | for x:=0 to Width-1 do begin
458 | Tmp[y,x] := Self[Width-x,y];
459 | end;
460 |
461 | Self.SetSize(Tmp.Width, Tmp.Height);
462 | Self.CopyFrom(Tmp);
463 |
464 | Tmp.Free;
465 | end;
466 |
467 | procedure TPV_Bitmap.Rotate180;
468 | var x,y: Integer;
469 | P: TPix;
470 | Tmp: TPV_Bitmap;
471 | begin
472 | Tmp := TPV_Bitmap.Create;
473 | Tmp.SetSize(Width, Height);
474 |
475 | for y:=0 to Height-1 do
476 | for x:=0 to Width-1 do begin
477 | Tmp[x,y] := Self[Width-x,Height-y];
478 | end;
479 |
480 | Self.SetSize(Tmp.Width, Tmp.Height);
481 | Self.CopyFrom(Tmp);
482 |
483 | Tmp.Free;
484 | end;
485 |
486 | procedure TPV_Bitmap.Rotate270;
487 | var x,y: Integer;
488 | P: TPix;
489 | Tmp: TPV_Bitmap;
490 | begin
491 | Tmp := TPV_Bitmap.Create;
492 | Tmp.SetSize(Height, Width);
493 |
494 | for y:=0 to Height-1 do
495 | for x:=0 to Width-1 do begin
496 | Tmp[y,x] := Self[x,Height-y];
497 | end;
498 |
499 | Self.SetSize(Tmp.Width, Tmp.Height);
500 | Self.CopyFrom(Tmp);
501 |
502 | Tmp.Free;
503 | end;
504 |
505 |
506 | procedure TPV_Bitmap.AddNoise(Amount: Byte);
507 | var x,y: Integer;
508 | P: PPix;
509 | R: Byte;
510 | White,Black: TPix;
511 | begin
512 | P := Self.Scanline[0];
513 |
514 | if Amount > 100 then Amount := 100;
515 |
516 | White := MakePix(255,255,255,255);
517 | Black := MakePix(0,0,0,255);
518 |
519 | for y:=0 to Height-1 do
520 | for x:=0 to Width-1 do begin
521 | R := Random(100);
522 |
523 | if R < Amount then begin
524 | if R mod 2 = 0 then P^.RGBA := White.RGBA
525 | else P^.RGBA := Black.RGBA;
526 | end;
527 |
528 | Inc(P);
529 | end;
530 | end;
531 |
532 | procedure TPV_Bitmap.Brightness(Amount: Byte);
533 | var x,y: Integer;
534 | P: PPix;
535 | R: Byte;
536 | Amount2: Single;
537 | begin
538 | P := Self.Scanline[0];
539 |
540 | if Amount > 100 then Amount := 100;
541 |
542 | Amount2 := Amount * 2.55;
543 |
544 | for y:=0 to Height-1 do
545 | for x:=0 to Width-1 do begin
546 |
547 | P^.R := Clip(P^.R + Amount);
548 | P^.G := Clip(P^.G + Amount);
549 | P^.B := Clip(P^.B + Amount);
550 |
551 | Inc(P);
552 | end;
553 | end;
554 |
555 | procedure TPV_Bitmap.Contrast(Amount: Extended);
556 | var x,y: Integer;
557 | P: PPix;
558 | R: Byte;
559 | Amount2: Single;
560 | LUT: array[0..255] of Byte;
561 | Val: Extended;
562 | i: Integer;
563 | begin
564 | P := Self.Scanline[0];
565 |
566 | for i:=0 to 255 do begin
567 | Val := Amount * (i- 127) + 127;
568 | LUT[i] := Clip(Val);
569 | end;
570 |
571 | Amount2 := Amount / 100;
572 |
573 | for y:=0 to Height-1 do
574 | for x:=0 to Width-1 do begin
575 |
576 | P^.R := LUT[P^.R];
577 | P^.G := LUT[P^.G];
578 | P^.B := LUT[P^.B];
579 |
580 | Inc(P);
581 | end;
582 | end;
583 |
584 | procedure TPV_Bitmap.FindEdges;
585 | begin
586 | Convolution([0,-1,0,
587 | -1,4,-1,
588 | 0,-1,0], 3);
589 | end;
590 |
591 | procedure TPV_Bitmap.FindEdges2;
592 | begin
593 | Convolution([-1,-1,-1,
594 | -1,8,-1,
595 | -1,-1,-1], 3);
596 | end;
597 |
598 | procedure TPV_Bitmap.FindEdges3;
599 | begin
600 | Convolution([1,0,-1,
601 | 0,0,0,
602 | -1,0,1], 3);
603 | end;
604 |
605 | procedure TPV_Bitmap.Negate;
606 | var x,y: Integer;
607 | P: TPix;
608 | begin
609 | Self.SetSize(Width, Height);
610 |
611 | for y:=0 to Height-1 do
612 | for x:=0 to Width-1 do begin
613 | P := Self[x,y];
614 |
615 | Self.SetRGB(x,y, 255-P.R, 255-P.G, 255-P.B);
616 | end;
617 | end;
618 |
619 | procedure TPV_Bitmap.Gamma(Amount: Extended);
620 | var x,y: Integer;
621 | P: PPix;
622 | R: Byte;
623 | Amount2: Single;
624 | LUT: array[0..255] of Byte;
625 | Val: Extended;
626 | i: Integer;
627 | begin
628 | P := Self.Scanline[0];
629 |
630 | for i:=0 to 255 do begin
631 | Val := 255 * Power(i/255, 1/Amount);
632 | LUT[i] := Clip(Val);
633 | end;
634 |
635 | for y:=0 to Height-1 do
636 | for x:=0 to Width-1 do begin
637 |
638 | P^.R := LUT[P^.R];
639 | P^.G := LUT[P^.G];
640 | P^.B := LUT[P^.B];
641 |
642 | Inc(P);
643 | end;
644 | end;
645 |
646 |
647 | procedure TPV_Bitmap.Sepia(Amount: Byte); //20-40
648 | var x,y: Integer;
649 | P: PPix;
650 | G: Byte;
651 | i: Integer;
652 | begin
653 | P := Self.Scanline[0];
654 |
655 | for y:=0 to Height-1 do
656 | for x:=0 to Width-1 do begin
657 |
658 | G := (P^.R + P^.G + P^.B) div 3;
659 |
660 | P^.R := Clip(G + 2*Amount);
661 | P^.G := Clip(G + Amount);
662 | P^.B := G;
663 |
664 | Inc(P);
665 | end;
666 | end;
667 |
668 | procedure TPV_Bitmap.Resample(AWidth, AHeight: Integer; Filter: TResampleFilter);
669 | var New: TPV_Bitmap;
670 | begin
671 | New := ResampleTo(AWidth, AHeight, Filter);
672 |
673 | CopyFrom(New);
674 | New.Free;
675 | end;
676 |
677 | procedure TPV_Bitmap.ResamplePercent(AWidth, AHeight: Integer;
678 | Filter: TResampleFilter);
679 | begin
680 | Resample(Round(AWidth * Self.Width/100), Round(AHeight * Self.Height/100), Filter);
681 | end;
682 |
683 | procedure TPV_Bitmap.BGR;
684 | var x,y: Integer;
685 | P: TPix;
686 | begin
687 | for y:=0 to Height-1 do
688 | for x:=0 to Width-1 do begin
689 | P := Self[x,y];
690 |
691 | Self.SetRGBA(x,y, P.B, P.G, P.R, P.A);
692 | end;
693 | end;
694 |
695 | procedure TPV_Bitmap.BRG;
696 | var x,y: Integer;
697 | P: TPix;
698 | begin
699 | for y:=0 to Height-1 do
700 | for x:=0 to Width-1 do begin
701 | P := Self[x,y];
702 |
703 | Self.SetRGBA(x,y, P.B, P.R, P.G, P.A);
704 | end;
705 | end;
706 |
707 | procedure TPV_Bitmap.GBR;
708 | var x,y: Integer;
709 | P: TPix;
710 | begin
711 | for y:=0 to Height-1 do
712 | for x:=0 to Width-1 do begin
713 | P := Self[x,y];
714 |
715 | Self.SetRGBA(x,y, P.G, P.B, P.R, P.A);
716 | end;
717 | end;
718 |
719 | procedure TPV_Bitmap.GRB;
720 | var x,y: Integer;
721 | P: TPix;
722 | begin
723 | for y:=0 to Height-1 do
724 | for x:=0 to Width-1 do begin
725 | P := Self[x,y];
726 |
727 | Self.SetRGBA(x,y, P.G, P.R, P.B, P.A);
728 | end;
729 | end;
730 |
731 | procedure TPV_Bitmap.RBG;
732 | var x,y: Integer;
733 | P: TPix;
734 | begin
735 | for y:=0 to Height-1 do
736 | for x:=0 to Width-1 do begin
737 | P := Self[x,y];
738 |
739 | Self.SetRGBA(x,y, P.R, P.B, P.G, P.A);
740 | end;
741 | end;
742 |
743 | procedure TPV_Bitmap.ExtractRed;
744 | var x,y: Integer;
745 | P: TPix;
746 | begin
747 | for y:=0 to Height-1 do
748 | for x:=0 to Width-1 do begin
749 | P := Self[x,y];
750 |
751 | Self.SetRGBA(x,y, P.R, P.R, P.R, P.A);
752 | end;
753 | end;
754 |
755 | procedure TPV_Bitmap.ExtractGreen;
756 | var x,y: Integer;
757 | P: TPix;
758 | begin
759 | for y:=0 to Height-1 do
760 | for x:=0 to Width-1 do begin
761 | P := Self[x,y];
762 |
763 | Self.SetRGBA(x,y, P.G, P.G, P.G, P.A);
764 | end;
765 | end;
766 |
767 | procedure TPV_Bitmap.ExtractBlue;
768 | var x,y: Integer;
769 | P: TPix;
770 | begin
771 | for y:=0 to Height-1 do
772 | for x:=0 to Width-1 do begin
773 | P := Self[x,y];
774 |
775 | Self.SetRGBA(x,y, P.B, P.B, P.B, P.A);
776 | end;
777 | end;
778 |
779 | procedure TPV_Bitmap.ExtractAlpha;
780 | var x,y: Integer;
781 | P: TPix;
782 | begin
783 | for y:=0 to Height-1 do
784 | for x:=0 to Width-1 do begin
785 | P := Self[x,y];
786 |
787 | Self.SetRGB(x,y, P.A, P.A, P.A);
788 | end;
789 | end;
790 |
791 | procedure TPV_Bitmap.ExtractCyan;
792 | var x,y: Integer;
793 | P: TPix;
794 | C,M,YY,K: Byte;
795 | begin
796 | for y:=0 to Height-1 do
797 | for x:=0 to Width-1 do begin
798 | P := Self[x,y];
799 |
800 | rgb2cmyk(P.R, P.G, P.B, C,M,YY,K);
801 | P.R := 255-Clip(C*2.55);
802 |
803 | Self.SetRGB(x,y, P.R, P.R, P.R);
804 | end;
805 | end;
806 |
807 | procedure TPV_Bitmap.ExtractMagenta;
808 | var x,y: Integer;
809 | P: TPix;
810 | C,M,YY,K: Byte;
811 | begin
812 | for y:=0 to Height-1 do
813 | for x:=0 to Width-1 do begin
814 | P := Self[x,y];
815 |
816 | rgb2cmyk(P.R, P.G, P.B, C,M,YY,K);
817 | P.R := 255-Clip(M*2.55);
818 |
819 | Self.SetRGB(x,y, P.R, P.R, P.R);
820 | end;
821 | end;
822 |
823 | procedure TPV_Bitmap.ExtractYellow;
824 | var x,y: Integer;
825 | P: TPix;
826 | C,M,YY,K: Byte;
827 | begin
828 | for y:=0 to Height-1 do
829 | for x:=0 to Width-1 do begin
830 | P := Self[x,y];
831 |
832 | rgb2cmyk(P.R, P.G, P.B, C,M,YY,K);
833 | P.R := 255-Clip(YY*2.55);
834 |
835 | Self.SetRGB(x,y, P.R, P.R, P.R);
836 | end;
837 | end;
838 |
839 | procedure TPV_Bitmap.ExtractBlack;
840 | var x,y: Integer;
841 | P: TPix;
842 | C,M,YY,K: Byte;
843 | begin
844 | for y:=0 to Height-1 do
845 | for x:=0 to Width-1 do begin
846 | P := Self[x,y];
847 |
848 | rgb2cmyk(P.R, P.G, P.B, C,M,YY,K);
849 | P.R := 255-Clip(K*2.55);
850 |
851 | Self.SetRGB(x,y, P.R, P.R, P.R);
852 | end;
853 | end;
854 |
855 |
856 | procedure TPV_Bitmap.SmarterBlur;
857 | var x,y: Integer;
858 | Curr, Other: TPix;
859 | Old: TPV_Bitmap;
860 | SumR, SumG, SumB: Int64;
861 | Count: Integer;
862 | i,j: Integer;
863 | Avg: TPix;
864 | begin
865 | Old := TPV_Bitmap.Create;
866 | Old.SetSize(Width, Height);
867 | Old.CopyFrom(Self);
868 |
869 | for y:=1 to Height-2 do
870 | for x:=1 to Width-2 do begin
871 |
872 | SumR := 0;
873 | SumG := 0;
874 | SumB := 0;
875 | Count := 0;
876 | Curr := Self[x,y];
877 |
878 | for i:=-1 to 1 do
879 | for j:=-1 to 1 do begin
880 | Other := Self[x+i, y+j];
881 | if SamePix(Other, Curr) then begin
882 | Inc(Count);
883 |
884 | Inc(SumR, Other.R);
885 | Inc(SumG, Other.G);
886 | Inc(SumB, Other.B);
887 | end;
888 | end;
889 |
890 | Avg.R := Clip(SumR / Count);
891 | Avg.G := Clip(SumG / Count);
892 | Avg.B := Clip(SumB / Count);
893 | Avg.A := 255;
894 |
895 | for i:=-1 to 1 do
896 | for j:=-1 to 1 do begin
897 | Other := Self[x+i, y+j];
898 | if SamePix(Other, Curr) then begin
899 | Self[x+i, y+j] := Avg;
900 | end;
901 | end;
902 | end;
903 |
904 | Old.Free;
905 | end;
906 |
907 | procedure TPV_Bitmap.Sharpen;
908 | begin
909 | Convolution([ 0,-1, 0,
910 | -1, 5,-1,
911 | 0,-1, 0], 3);
912 | end;
913 |
914 | procedure TPV_Bitmap.DeNoise;
915 | var x,y: Integer;
916 | Old: TPV_Bitmap;
917 | P0,P1,P2,P3,P4,P5,P6,P7,P8: TPix;
918 | Avg: TPix;
919 | begin
920 | Old := TPV_Bitmap.Create;
921 | Old.SetSize(Width, Height);
922 | Old.CopyFrom(Self);
923 |
924 | for y:=1 to Height-2 do
925 | for x:=1 to Width-2 do begin
926 |
927 | P1 := Old[x-1,y-1];
928 | P2 := Old[x ,y-1];
929 | P3 := Old[x+1,y-1];
930 |
931 | P4 := Old[x-1,y ];
932 | P0 := Old[x ,y ];
933 | P5 := Old[x+1,y ];
934 |
935 | P6 := Old[x-1,y+1];
936 | P7 := Old[x ,y+1];
937 | P8 := Old[x+1,y+1];
938 |
939 | Avg.R := Clip((P1.R + P2.R + P3.R + P4.R + P5.R + P6.R + P7.R + P8.R) / 8);
940 | Avg.G := Clip((P1.G + P2.G + P3.G + P4.G + P5.G + P6.G + P7.G + P8.G) / 8);
941 | Avg.B := Clip((P1.B + P2.B + P3.B + P4.B + P5.B + P6.B + P7.B + P8.B) / 8);
942 | Avg.A := 255;
943 |
944 | if not SamePix(P0,Avg, 130) then begin
945 | Self[x,y] := Avg;
946 | end;
947 |
948 | end;
949 |
950 | Old.Free;
951 | end;
952 |
953 | procedure TPV_Bitmap.Emboss;
954 | begin
955 | Convolution([-2,-1, 0,
956 | -1, 1, 1,
957 | 0, 1, 2], 3);
958 | end;
959 |
960 | procedure TPV_Bitmap.BoxBlur;
961 | begin
962 | Convolution([ 1, 1, 1,
963 | 1, 1, 1,
964 | 1, 1, 1], 3, 9);
965 | end;
966 |
967 | procedure TPV_Bitmap.GaussBlur;
968 | begin
969 | Convolution([1,2,1,
970 | 2,4,2,
971 | 1,2,1], 3, 16);
972 | end;
973 |
974 | procedure TPV_Bitmap.GaussBlur5;
975 | begin
976 | Convolution([ 1, 4, 6, 4, 1,
977 | 4,16,24,16, 4,
978 | 6,24,36,24, 6,
979 | 4,16,24,16, 4,
980 | 1, 4, 6, 4, 1], 5, 256);
981 | end;
982 |
983 | procedure TPV_Bitmap.Unsharp;
984 | begin
985 | Convolution([ 1, 4, 6, 4, 1,
986 | 4, 16, 24, 16, 4,
987 | 6, 24,-476, 24, 6,
988 | 4, 16, 24, 16, 4,
989 | 1, 4, 6, 4, 1], 5, -256);
990 | end;
991 |
992 | procedure TPV_Bitmap.Convolution(Kernel: array of Double; Size: Byte; Divider: Integer);
993 | var x,y: Integer;
994 | i,j: Integer;
995 | ii: Integer;
996 | AccR, AccG, AccB: Extended;
997 | Half: Integer;
998 | R,G,B: Byte;
999 | Old: TPV_Bitmap;
1000 | begin
1001 | Old := TPV_Bitmap.Create;
1002 | Old.SetSize(Width, Height);
1003 | Old.CopyFrom(Self);
1004 |
1005 | Half := Floor(Size/2);
1006 |
1007 | for y:=Half to Height-1-Half do
1008 | for x:=Half to Width-1-Half do begin
1009 | AccR := 0;
1010 | AccG := 0;
1011 | AccB := 0;
1012 | ii := 0;
1013 |
1014 | for j:=-Half to Half do
1015 | for i:=-Half to Half do begin
1016 | AccR := AccR + Kernel[ii] * Old[x+i, y+j].R;
1017 | AccG := AccG + Kernel[ii] * Old[x+i, y+j].G;
1018 | AccB := AccB + Kernel[ii] * Old[x+i, y+j].B;
1019 |
1020 | Inc(ii);
1021 | end;
1022 |
1023 | R := Clip(AccR / Divider);
1024 | G := Clip(AccG / Divider);
1025 | B := Clip(AccB / Divider);
1026 |
1027 | Self.SetRGB(x,y, R,G,B);
1028 | end;
1029 |
1030 | Old.Free;
1031 | end;
1032 |
1033 | end.
1034 |
--------------------------------------------------------------------------------
/PV_Grayscale.pas:
--------------------------------------------------------------------------------
1 | unit PV_Grayscale;
2 |
3 | //Lazzy Image Viewer
4 | //github.com/PascalVault
5 | //License: MIT
6 |
7 | interface
8 |
9 | uses Graphics, Math, PV_Bitmap;
10 |
11 |
12 | procedure Grayscale(Bmp: TPV_Bitmap; MaxColors: Byte; Dither: TDither = ddFloyd);
13 | procedure BlackWhite(Bmp: TPV_Bitmap; Dither: TDither = ddFloyd);
14 |
15 | implementation
16 |
17 |
18 | function Clip(Val: Extended): Byte;
19 | begin
20 | if Val > 255 then Result := 255
21 | else if Val < 0 then Result := 0
22 | else Result := Round(Val);
23 | end;
24 |
25 | procedure _atkinson(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
26 | //Bill Atkinson dithering
27 | var DiffR, DiffG, DiffB: Extended;
28 | begin
29 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-3) then Exit;
30 |
31 | DiffR := (1/8) * error.R;
32 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR));
33 | Bmp.SetR(x+2, y , Clip(Bmp[x+2, y ].R + DiffR));
34 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR));
35 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR));
36 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR));
37 | Bmp.SetR(x , y+2, Clip(Bmp[x , y+2].R + DiffR));
38 | end;
39 |
40 | procedure _jarvis(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
41 | //Jarvis-Judice-Ninke dithering
42 | var DiffR, DiffG, DiffB: Extended;
43 | begin
44 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-3) then Exit;
45 |
46 | DiffR := (1/48) * error.R;
47 | Bmp.SetR(x + 1, y , Clip(Bmp[x+1, y ].R + DiffR * 7));
48 | Bmp.SetR(x + 2, y , Clip(Bmp[x+2, y ].R + DiffR * 5));
49 | Bmp.SetR(x - 2, y + 1, Clip(Bmp[x-2, y+1].R + DiffR * 3));
50 | Bmp.SetR(x - 1, y + 1, Clip(Bmp[x-1, y+1].R + DiffR * 5));
51 | Bmp.SetR(x , y + 1, Clip(Bmp[x , y+1].R + DiffR * 7));
52 | Bmp.SetR(x + 1, y + 1, Clip(Bmp[x+1, y+1].R + DiffR * 5));
53 | Bmp.SetR(x + 2, y + 1, Clip(Bmp[x+2, y+1].R + DiffR * 3));
54 | Bmp.SetR(x - 2, y + 2, Clip(Bmp[x-2, y+2].R + DiffR * 1));
55 | Bmp.SetR(x - 1, y + 2, Clip(Bmp[x-1, y+2].R + DiffR * 3));
56 | Bmp.SetR(x , y + 2, Clip(Bmp[x , y+2].R + DiffR * 5));
57 | Bmp.SetR(x + 1, y + 2, Clip(Bmp[x+1, y+2].R + DiffR * 3));
58 | Bmp.SetR(x + 2, y + 2, Clip(Bmp[x+2, y+2].R + DiffR * 1));
59 | end;
60 |
61 | procedure _sierra2(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
62 | //Sierra 2 dithering
63 | var DiffR, DiffG, DiffB: Extended;
64 | begin
65 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-3) then Exit;
66 |
67 | DiffR := (1/16) * error.R;
68 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 4));
69 | Bmp.SetR(x+2, y , Clip(Bmp[x+2, y ].R + DiffR * 3));
70 | Bmp.SetR(x-2, y+1, Clip(Bmp[x-2, y+1].R + DiffR * 1));
71 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 2));
72 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 3));
73 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR * 2));
74 | Bmp.SetR(x+2, y+1, Clip(Bmp[x+2, y+1].R + DiffR * 1));
75 | end;
76 |
77 | procedure _sierra3(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
78 | //Sierra 3 dithering
79 | var DiffR, DiffG, DiffB: Extended;
80 | begin
81 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-3) then Exit;
82 |
83 | DiffR := (1/32) * error.R;
84 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 5));
85 | Bmp.SetR(x+2, y , Clip(Bmp[x+2, y ].R + DiffR * 3));
86 | Bmp.SetR(x-2, y+1, Clip(Bmp[x-2, y+1].R + DiffR * 2));
87 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 4));
88 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 5));
89 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR * 4));
90 | Bmp.SetR(x+2, y+1, Clip(Bmp[x+2, y+1].R + DiffR * 2));
91 | Bmp.SetR(x-1, y+2, Clip(Bmp[x-1, y+2].R + DiffR * 2));
92 | Bmp.SetR(x , y+2, Clip(Bmp[x , y+2].R + DiffR * 3));
93 | Bmp.SetR(x+1, y+2, Clip(Bmp[x+1, y+2].R + DiffR * 2));
94 | end;
95 |
96 | procedure _sierra4(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
97 | //Sierra 2-4a dithering
98 | var DiffR, DiffG, DiffB: Extended;
99 | begin
100 | if (x < 1) or (x > Bmp.Width-1) or (y > Bmp.Height-2) then Exit;
101 |
102 | DiffR := (1/4) * error.R;
103 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 2));
104 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 1));
105 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 1));
106 | end;
107 |
108 | procedure _stucki(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
109 | //Stucki dithering
110 | var DiffR, DiffG, DiffB: Extended;
111 | begin
112 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-3) then Exit;
113 |
114 | DiffR := (1/42) * error.R;
115 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 8));
116 | Bmp.SetR(x+2, y , Clip(Bmp[x+2, y ].R + DiffR * 4));
117 | Bmp.SetR(x-2, y+1, Clip(Bmp[x-2, y+1].R + DiffR * 2));
118 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 4));
119 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 8));
120 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR * 4));
121 | Bmp.SetR(x+2, y+1, Clip(Bmp[x+2, y+1].R + DiffR * 2));
122 | Bmp.SetR(x-2, y+2, Clip(Bmp[x-2, y+2].R + DiffR * 1));
123 | Bmp.SetR(x-1, y+2, Clip(Bmp[x-1, y+2].R + DiffR * 2));
124 | Bmp.SetR(x , y+2, Clip(Bmp[x , y+2].R + DiffR * 4));
125 | Bmp.SetR(x+1, y+2, Clip(Bmp[x+1, y+2].R + DiffR * 2));
126 | Bmp.SetR(x+2, y+2, Clip(Bmp[x+2, y+2].R + DiffR * 1));
127 | end;
128 |
129 | procedure _burkes(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
130 | //Burkes dithering
131 | var DiffR, DiffG, DiffB: Extended;
132 | begin
133 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-2) then Exit;
134 |
135 | DiffR := (1/32) * error.R;
136 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 8));
137 | Bmp.SetR(x+2, y , Clip(Bmp[x+2, y ].R + DiffR * 4));
138 | Bmp.SetR(x-2, y+1, Clip(Bmp[x-2, y+1].R + DiffR * 2));
139 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 4));
140 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 8));
141 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR * 4));
142 | Bmp.SetR(x+2, y+1, Clip(Bmp[x+2, y+1].R + DiffR * 2));
143 | end;
144 |
145 | procedure _floyd(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
146 | //Floyd-Steinberg dithering
147 | var DiffR, DiffG, DiffB: Extended;
148 | begin
149 | if (x < 1) or (x > Bmp.Width-2) or (y > Bmp.Height-2) then Exit;
150 |
151 | DiffR := (1/16) * Error.R;
152 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 7) );
153 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 3) );
154 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 5) );
155 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR * 1) );
156 | end;
157 |
158 | procedure Grayscale(Bmp: TPV_Bitmap; MaxColors: Byte; Dither: TDither);
159 | var i: Integer;
160 | x,y: Integer;
161 | P: PPix;
162 | R,G,B: Byte;
163 | Error: TPixInt;
164 | Ratio: Extended;
165 | begin
166 | Ratio := 255/MaxColors;
167 |
168 | //Bmp.FBitmap.BeginUpdate(False);
169 |
170 | for y:=0 to Bmp.Height-1 do begin
171 | P := Bmp.Scanline[y];
172 |
173 | for x:=0 to Bmp.Width-1 do begin
174 | //R := Floor((P^.R + P^.G + P^.B)/3);
175 | R := Round(0.2126*P^.R + 0.7152*P^.G + 0.0722*P^.B);
176 | R := Floor(Ratio * Floor(R/Ratio));
177 |
178 | Error.R := P^.R-R;
179 |
180 | P^.R := R;
181 |
182 | case Dither of
183 | ddSierra2 : _Sierra2(Error, x,y, Bmp);
184 | ddSierra3 : _Sierra3(Error, x,y, Bmp);
185 | ddSierra4 : _Sierra4(Error, x,y, Bmp);
186 | ddJarvis : _Jarvis(Error, x,y, Bmp);
187 | ddAtkinson : _Atkinson(Error, x,y, Bmp);
188 | ddStucki : _Stucki(Error, x,y, Bmp);
189 | ddFloyd : _Floyd(Error, x,y, Bmp);
190 | ddBurkes : _Burkes(Error, x,y, Bmp);
191 | end;
192 |
193 | Inc(P);
194 | end;
195 | end;
196 |
197 | //set G,B to R
198 | for y:=0 to Bmp.Height-1 do
199 | for x:=0 to Bmp.Width-1 do begin
200 | R := Bmp[x,y].R;
201 |
202 | Bmp.SetG(x,y, R);
203 | Bmp.SetB(x,y, R);
204 | end;
205 |
206 | //Bmp.FBitmap.EndUpdate();
207 | end;
208 |
209 | procedure BlackWhite(Bmp: TPV_Bitmap; Dither: TDither);
210 | var i: Integer;
211 | x,y: Integer;
212 | P: PPix;
213 | R,G,B: Byte;
214 | Error: TPixInt;
215 | begin
216 | //Bmp.FBitmap.BeginUpdate(False);
217 |
218 | for y:=0 to Bmp.Height-1 do begin
219 | P := Bmp.Scanline[y];
220 |
221 | for x:=0 to Bmp.Width-1 do begin
222 | if P^.R > 127 then R := 255
223 | else R := 0;
224 |
225 | Error.R := P^.R-R;
226 |
227 | P^.R := R;
228 |
229 | case Dither of
230 | ddSierra2 : _Sierra2(Error, x,y, Bmp);
231 | ddSierra3 : _Sierra3(Error, x,y, Bmp);
232 | ddSierra4 : _Sierra4(Error, x,y, Bmp);
233 | ddJarvis : _Jarvis(Error, x,y, Bmp);
234 | ddAtkinson : _Atkinson(Error, x,y, Bmp);
235 | ddStucki : _Stucki(Error, x,y, Bmp);
236 | ddFloyd : _Floyd(Error, x,y, Bmp);
237 | ddBurkes : _Burkes(Error, x,y, Bmp);
238 | end;
239 |
240 | Inc(P);
241 | end;
242 | end;
243 |
244 | //set G,B to R
245 | for y:=0 to Bmp.Height-1 do
246 | for x:=0 to Bmp.Width-1 do begin
247 | R := Bmp[x,y].R;
248 |
249 | Bmp.SetG(x,y, R);
250 | Bmp.SetB(x,y, R);
251 | end;
252 |
253 | //Bmp.FBitmap.EndUpdate();
254 | end;
255 |
256 | end.
257 |
--------------------------------------------------------------------------------
/PV_Palette.pas:
--------------------------------------------------------------------------------
1 | unit PV_Palette;
2 |
3 | //Lazzy Image Viewer
4 | //github.com/PascalVault
5 | //License: MIT
6 |
7 | interface
8 |
9 | uses Graphics, Math, PV_Bitmap;
10 |
11 | type
12 | TOctreeNode = class; // Forward definition so TReducibleNodes can be declared
13 |
14 | TReducibleNodes = array[0..7] of TOctreeNode;
15 |
16 | TOctreeNode = Class(TObject)
17 | public
18 | IsLeaf : Boolean;
19 | PixelCount : integer;
20 | SumR, SumG, SumB : Integer;
21 | GreenSum : integer;
22 | BlueSum : integer;
23 | Next : TOctreeNode;
24 | Child : TReducibleNodes;
25 |
26 | constructor Create(Level: integer; ColorBits: integer; var LeafCount: integer;
27 | var ReducibleNodes: TReducibleNodes);
28 | destructor Destroy; override;
29 | end;
30 |
31 | TColorQuantizer = class(TObject)
32 | private
33 | FTree : TOctreeNode;
34 | FLeafCount : integer;
35 | FReducibleNodes : TReducibleNodes;
36 | FMaxColors : integer;
37 | FColorBits : integer;
38 |
39 | protected
40 | procedure AddColor(var Node: TOctreeNode; r, g, b: byte; ColorBits: integer;
41 | Level: integer; var LeafCount: integer; var ReducibleNodes: TReducibleNodes);
42 | procedure DeleteTree(var Node: TOctreeNode);
43 | procedure GetPaletteColors(const Node: TOctreeNode;
44 | var RGBQuadArray: TPalArray; var Index: integer);
45 | procedure ReduceTree(ColorBits: integer; var LeafCount: integer;
46 | var ReducibleNodes: TReducibleNodes);
47 |
48 | public
49 | constructor Create(MaxColors: integer; ColorBits: integer);
50 | destructor Destroy; override;
51 |
52 | procedure GetColorTable(var RGBQuadArray: TPalArray);
53 | function ProcessImage(const Bmp: TPV_Bitmap): boolean;
54 |
55 | property ColorCount: integer read FLeafCount;
56 | end;
57 |
58 | procedure ReduceColors(Bmp: TPV_Bitmap; MaxColors: Byte; Dither: TDither = ddFloyd);
59 |
60 | implementation
61 |
62 |
63 | function ColorDistance(r,g,b: Byte; rr,gg,bb: Byte): Int64;
64 | begin
65 | Result := (rr-r)*(rr-r) + (gg-g)*(gg-g) + (bb-b)*(bb-b);
66 | end;
67 |
68 | procedure BestColor(r,g,b: Byte; pal: array of TPix; palSize: Integer; out rr,gg,bb: Byte);
69 | var i: Integer;
70 | BestDist: Int64;
71 | BestIndex: Byte;
72 | CurDist: Int64;
73 | begin
74 | BestDist := 255*255*3;
75 | BestIndex := 0;
76 |
77 | for i:=0 to PalSize-1 do begin
78 | CurDist := ColorDistance(r,g,b , pal[i].r, pal[i].g, pal[i].b);
79 | if CurDist < BestDist then begin
80 | BestDist := CurDist;
81 | BestIndex := i;
82 | end;
83 | end;
84 |
85 | rr := pal[BestIndex].R;
86 | gg := pal[BestIndex].G;
87 | bb := pal[BestIndex].B;
88 | end;
89 |
90 | function Clip(Val: Extended): Byte;
91 | begin
92 | if Val > 255 then Result := 255
93 | else if Val < 0 then Result := 0
94 | else Result := Round(Val);
95 | end;
96 |
97 | procedure _atkinson(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
98 | //Bill Atkinson dithering
99 | var DiffR, DiffG, DiffB: Extended;
100 | begin
101 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-3) then Exit;
102 |
103 | DiffR := (1/8) * error.R;
104 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR));
105 | Bmp.SetR(x+2, y , Clip(Bmp[x+2, y ].R + DiffR));
106 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR));
107 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR));
108 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR));
109 | Bmp.SetR(x , y+2, Clip(Bmp[x , y+2].R + DiffR));
110 |
111 | DiffG := (1/8) * error.G;
112 | Bmp.SetG(x+1, y , Clip(Bmp[x+1, y ].G + DiffG));
113 | Bmp.SetG(x+2, y , Clip(Bmp[x+2, y ].G + DiffG));
114 | Bmp.SetG(x-1, y+1, Clip(Bmp[x-1, y+1].G + DiffG));
115 | Bmp.SetG(x , y+1, Clip(Bmp[x , y+1].G + DiffG));
116 | Bmp.SetG(x+1, y+1, Clip(Bmp[x+1, y+1].G + DiffG));
117 | Bmp.SetG(x , y+2, Clip(Bmp[x , y+2].G + DiffG));
118 |
119 | DiffB := (1/8) * error.B;
120 | Bmp.SetB(x+1, y , Clip(Bmp[x+1, y ].B + DiffB));
121 | Bmp.SetB(x+2, y , Clip(Bmp[x+2, y ].B + DiffB));
122 | Bmp.SetB(x-1, y+1, Clip(Bmp[x-1, y+1].B + DiffB));
123 | Bmp.SetB(x , y+1, Clip(Bmp[x , y+1].B + DiffB));
124 | Bmp.SetB(x+1, y+1, Clip(Bmp[x+1, y+1].B + DiffB));
125 | Bmp.SetB(x , y+2, Clip(Bmp[x , y+2].B + DiffB));
126 | end;
127 |
128 | procedure _jarvis(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
129 | //Jarvis-Judice-Ninke dithering
130 | var DiffR, DiffG, DiffB: Extended;
131 | begin
132 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-3) then Exit;
133 |
134 | DiffR := (1/48) * error.R;
135 | Bmp.SetR(x + 1, y , Clip(Bmp[x+1, y ].R + DiffR * 7));
136 | Bmp.SetR(x + 2, y , Clip(Bmp[x+2, y ].R + DiffR * 5));
137 | Bmp.SetR(x - 2, y + 1, Clip(Bmp[x-2, y+1].R + DiffR * 3));
138 | Bmp.SetR(x - 1, y + 1, Clip(Bmp[x-1, y+1].R + DiffR * 5));
139 | Bmp.SetR(x , y + 1, Clip(Bmp[x , y+1].R + DiffR * 7));
140 | Bmp.SetR(x + 1, y + 1, Clip(Bmp[x+1, y+1].R + DiffR * 5));
141 | Bmp.SetR(x + 2, y + 1, Clip(Bmp[x+2, y+1].R + DiffR * 3));
142 | Bmp.SetR(x - 2, y + 2, Clip(Bmp[x-2, y+2].R + DiffR * 1));
143 | Bmp.SetR(x - 1, y + 2, Clip(Bmp[x-1, y+2].R + DiffR * 3));
144 | Bmp.SetR(x , y + 2, Clip(Bmp[x , y+2].R + DiffR * 5));
145 | Bmp.SetR(x + 1, y + 2, Clip(Bmp[x+1, y+2].R + DiffR * 3));
146 | Bmp.SetR(x + 2, y + 2, Clip(Bmp[x+2, y+2].R + DiffR * 1));
147 |
148 | DiffG := (1/48) * error.G;
149 | Bmp.SetG(x + 1, y , Clip(Bmp[x+1, y ].G + DiffG * 7));
150 | Bmp.SetG(x + 2, y , Clip(Bmp[x+2, y ].G + DiffG * 5));
151 | Bmp.SetG(x - 2, y + 1, Clip(Bmp[x-2, y+1].G + DiffG * 3));
152 | Bmp.SetG(x - 1, y + 1, Clip(Bmp[x-1, y+1].G + DiffG * 5));
153 | Bmp.SetG(x , y + 1, Clip(Bmp[x , y+1].G + DiffG * 7));
154 | Bmp.SetG(x + 1, y + 1, Clip(Bmp[x+1, y+1].G + DiffG * 5));
155 | Bmp.SetG(x + 2, y + 1, Clip(Bmp[x+2, y+1].G + DiffG * 3));
156 | Bmp.SetG(x - 2, y + 2, Clip(Bmp[x-2, y+2].G + DiffG * 1));
157 | Bmp.SetG(x - 1, y + 2, Clip(Bmp[x-1, y+2].G + DiffG * 3));
158 | Bmp.SetG(x , y + 2, Clip(Bmp[x , y+2].G + DiffG * 5));
159 | Bmp.SetG(x + 1, y + 2, Clip(Bmp[x+1, y+2].G + DiffG * 3));
160 | Bmp.SetG(x + 2, y + 2, Clip(Bmp[x+2, y+2].G + DiffG * 1));
161 |
162 | DiffB := (1/48) * error.B;
163 | Bmp.SetB(x + 1, y , Clip(Bmp[x+1, y ].B + DiffB * 7));
164 | Bmp.SetB(x + 2, y , Clip(Bmp[x+2, y ].B + DiffB * 5));
165 | Bmp.SetB(x - 2, y + 1, Clip(Bmp[x-2, y+1].B + DiffB * 3));
166 | Bmp.SetB(x - 1, y + 1, Clip(Bmp[x-1, y+1].B + DiffB * 5));
167 | Bmp.SetB(x , y + 1, Clip(Bmp[x , y+1].B + DiffB * 7));
168 | Bmp.SetB(x + 1, y + 1, Clip(Bmp[x+1, y+1].B + DiffB * 5));
169 | Bmp.SetB(x + 2, y + 1, Clip(Bmp[x+2, y+1].B + DiffB * 3));
170 | Bmp.SetB(x - 2, y + 2, Clip(Bmp[x-2, y+2].B + DiffB * 1));
171 | Bmp.SetB(x - 1, y + 2, Clip(Bmp[x-1, y+2].B + DiffB * 3));
172 | Bmp.SetB(x , y + 2, Clip(Bmp[x , y+2].B + DiffB * 5));
173 | Bmp.SetB(x + 1, y + 2, Clip(Bmp[x+1, y+2].B + DiffB * 3));
174 | Bmp.SetB(x + 2, y + 2, Clip(Bmp[x+2, y+2].B + DiffB * 1));
175 | end;
176 |
177 | procedure _sierra2(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
178 | //Sierra 2 dithering
179 | var DiffR, DiffG, DiffB: Extended;
180 | begin
181 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-3) then Exit;
182 |
183 | DiffR := (1/16) * error.R;
184 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 4));
185 | Bmp.SetR(x+2, y , Clip(Bmp[x+2, y ].R + DiffR * 3));
186 | Bmp.SetR(x-2, y+1, Clip(Bmp[x-2, y+1].R + DiffR * 1));
187 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 2));
188 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 3));
189 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR * 2));
190 | Bmp.SetR(x+2, y+1, Clip(Bmp[x+2, y+1].R + DiffR * 1));
191 |
192 | DiffG := (1/16) * error.G;
193 | Bmp.SetG(x+1, y , Clip(Bmp[x+1, y ].G + DiffG * 4));
194 | Bmp.SetG(x+2, y , Clip(Bmp[x+2, y ].G + DiffG * 3));
195 | Bmp.SetG(x-2, y+1, Clip(Bmp[x-2, y+1].G + DiffG * 1));
196 | Bmp.SetG(x-1, y+1, Clip(Bmp[x-1, y+1].G + DiffG * 2));
197 | Bmp.SetG(x , y+1, Clip(Bmp[x , y+1].G + DiffG * 3));
198 | Bmp.SetG(x+1, y+1, Clip(Bmp[x+1, y+1].G + DiffG * 2));
199 | Bmp.SetG(x+2, y+1, Clip(Bmp[x+2, y+1].G + DiffG * 1));
200 |
201 | DiffB := (1/16) * error.B;
202 | Bmp.SetB(x+1, y , Clip(Bmp[x+1, y ].B + DiffB * 4));
203 | Bmp.SetB(x+2, y , Clip(Bmp[x+2, y ].B + DiffB * 3));
204 | Bmp.SetB(x-2, y+1, Clip(Bmp[x-2, y+1].B + DiffB * 1));
205 | Bmp.SetB(x-1, y+1, Clip(Bmp[x-1, y+1].B + DiffB * 2));
206 | Bmp.SetB(x , y+1, Clip(Bmp[x , y+1].B + DiffB * 3));
207 | Bmp.SetB(x+1, y+1, Clip(Bmp[x+1, y+1].B + DiffB * 2));
208 | Bmp.SetB(x+2, y+1, Clip(Bmp[x+2, y+1].B + DiffB * 1));
209 | end;
210 |
211 | procedure _sierra3(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
212 | //Sierra 3 dithering
213 | var DiffR, DiffG, DiffB: Extended;
214 | begin
215 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-3) then Exit;
216 |
217 | DiffR := (1/32) * error.R;
218 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 5));
219 | Bmp.SetR(x+2, y , Clip(Bmp[x+2, y ].R + DiffR * 3));
220 | Bmp.SetR(x-2, y+1, Clip(Bmp[x-2, y+1].R + DiffR * 2));
221 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 4));
222 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 5));
223 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR * 4));
224 | Bmp.SetR(x+2, y+1, Clip(Bmp[x+2, y+1].R + DiffR * 2));
225 | Bmp.SetR(x-1, y+2, Clip(Bmp[x-1, y+2].R + DiffR * 2));
226 | Bmp.SetR(x , y+2, Clip(Bmp[x , y+2].R + DiffR * 3));
227 | Bmp.SetR(x+1, y+2, Clip(Bmp[x+1, y+2].R + DiffR * 2));
228 |
229 | DiffG := (1/32) * error.G;
230 | Bmp.SetG(x+1, y , Clip(Bmp[x+1, y ].G + DiffG * 5));
231 | Bmp.SetG(x+2, y , Clip(Bmp[x+2, y ].G + DiffG * 3));
232 | Bmp.SetG(x-2, y+1, Clip(Bmp[x-2, y+1].G + DiffG * 2));
233 | Bmp.SetG(x-1, y+1, Clip(Bmp[x-1, y+1].G + DiffG * 4));
234 | Bmp.SetG(x , y+1, Clip(Bmp[x , y+1].G + DiffG * 5));
235 | Bmp.SetG(x+1, y+1, Clip(Bmp[x+1, y+1].G + DiffG * 4));
236 | Bmp.SetG(x+2, y+1, Clip(Bmp[x+2, y+1].G + DiffG * 2));
237 | Bmp.SetG(x-1, y+2, Clip(Bmp[x-1, y+2].G + DiffG * 2));
238 | Bmp.SetG(x , y+2, Clip(Bmp[x , y+2].G + DiffG * 3));
239 | Bmp.SetG(x+1, y+2, Clip(Bmp[x+1, y+2].G + DiffG * 2));
240 |
241 | DiffB := (1/32) * error.B;
242 | Bmp.SetB(x+1, y , Clip(Bmp[x+1, y ].B + DiffB * 5));
243 | Bmp.SetB(x+2, y , Clip(Bmp[x+2, y ].B + DiffB * 3));
244 | Bmp.SetB(x-2, y+1, Clip(Bmp[x-2, y+1].B + DiffB * 2));
245 | Bmp.SetB(x-1, y+1, Clip(Bmp[x-1, y+1].B + DiffB * 4));
246 | Bmp.SetB(x , y+1, Clip(Bmp[x , y+1].B + DiffB * 5));
247 | Bmp.SetB(x+1, y+1, Clip(Bmp[x+1, y+1].B + DiffB * 4));
248 | Bmp.SetB(x+2, y+1, Clip(Bmp[x+2, y+1].B + DiffB * 2));
249 | Bmp.SetB(x-1, y+2, Clip(Bmp[x-1, y+2].B + DiffB * 2));
250 | Bmp.SetB(x , y+2, Clip(Bmp[x , y+2].B + DiffB * 3));
251 | Bmp.SetB(x+1, y+2, Clip(Bmp[x+1, y+2].B + DiffB * 2));
252 | end;
253 |
254 | procedure _sierra4(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
255 | //Sierra 2-4a dithering
256 | var DiffR, DiffG, DiffB: Extended;
257 | begin
258 | if (x < 1) or (x > Bmp.Width-1) or (y > Bmp.Height-2) then Exit;
259 |
260 | DiffR := (1/4) * error.R;
261 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 2));
262 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 1));
263 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 1));
264 |
265 | DiffG := (1/4) * error.G;
266 | Bmp.SetG(x+1, y , Clip(Bmp[x+1, y ].G + DiffG * 2));
267 | Bmp.SetG(x-1, y+1, Clip(Bmp[x-1, y+1].G + DiffG * 1));
268 | Bmp.SetG(x , y+1, Clip(Bmp[x , y+1].G + DiffG * 1));
269 |
270 | DiffB := (1/4) * error.B;
271 | Bmp.SetB(x+1, y , Clip(Bmp[x+1, y ].B + DiffB * 2));
272 | Bmp.SetB(x-1, y+1, Clip(Bmp[x-1, y+1].B + DiffB * 1));
273 | Bmp.SetB(x , y+1, Clip(Bmp[x , y+1].B + DiffB * 1));
274 | end;
275 |
276 | procedure _stucki(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
277 | //Stucki dithering
278 | var DiffR, DiffG, DiffB: Extended;
279 | begin
280 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-3) then Exit;
281 |
282 | DiffR := (1/42) * error.R;
283 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 8));
284 | Bmp.SetR(x+2, y , Clip(Bmp[x+2, y ].R + DiffR * 4));
285 | Bmp.SetR(x-2, y+1, Clip(Bmp[x-2, y+1].R + DiffR * 2));
286 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 4));
287 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 8));
288 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR * 4));
289 | Bmp.SetR(x+2, y+1, Clip(Bmp[x+2, y+1].R + DiffR * 2));
290 | Bmp.SetR(x-2, y+2, Clip(Bmp[x-2, y+2].R + DiffR * 1));
291 | Bmp.SetR(x-1, y+2, Clip(Bmp[x-1, y+2].R + DiffR * 2));
292 | Bmp.SetR(x , y+2, Clip(Bmp[x , y+2].R + DiffR * 4));
293 | Bmp.SetR(x+1, y+2, Clip(Bmp[x+1, y+2].R + DiffR * 2));
294 | Bmp.SetR(x+2, y+2, Clip(Bmp[x+2, y+2].R + DiffR * 1));
295 |
296 | DiffG := (1/42) * error.G;
297 | Bmp.SetG(x+1, y , Clip(Bmp[x+1, y ].G + DiffG * 8));
298 | Bmp.SetG(x+2, y , Clip(Bmp[x+2, y ].G + DiffG * 4));
299 | Bmp.SetG(x-2, y+1, Clip(Bmp[x-2, y+1].G + DiffG * 2));
300 | Bmp.SetG(x-1, y+1, Clip(Bmp[x-1, y+1].G + DiffG * 4));
301 | Bmp.SetG(x , y+1, Clip(Bmp[x , y+1].G + DiffG * 8));
302 | Bmp.SetG(x+1, y+1, Clip(Bmp[x+1, y+1].G + DiffG * 4));
303 | Bmp.SetG(x+2, y+1, Clip(Bmp[x+2, y+1].G + DiffG * 2));
304 | Bmp.SetG(x-2, y+2, Clip(Bmp[x-2, y+2].G + DiffG * 1));
305 | Bmp.SetG(x-1, y+2, Clip(Bmp[x-1, y+2].G + DiffG * 2));
306 | Bmp.SetG(x , y+2, Clip(Bmp[x , y+2].G + DiffG * 4));
307 | Bmp.SetG(x+1, y+2, Clip(Bmp[x+1, y+2].G + DiffG * 2));
308 | Bmp.SetG(x+2, y+2, Clip(Bmp[x+2, y+2].G + DiffG * 1));
309 |
310 | DiffB := (1/42) * error.B;
311 | Bmp.SetB(x+1, y , Clip(Bmp[x+1, y ].B + DiffB * 8));
312 | Bmp.SetB(x+2, y , Clip(Bmp[x+2, y ].B + DiffB * 4));
313 | Bmp.SetB(x-2, y+1, Clip(Bmp[x-2, y+1].B + DiffB * 2));
314 | Bmp.SetB(x-1, y+1, Clip(Bmp[x-1, y+1].B + DiffB * 4));
315 | Bmp.SetB(x , y+1, Clip(Bmp[x , y+1].B + DiffB * 8));
316 | Bmp.SetB(x+1, y+1, Clip(Bmp[x+1, y+1].B + DiffB * 4));
317 | Bmp.SetB(x+2, y+1, Clip(Bmp[x+2, y+1].B + DiffB * 2));
318 | Bmp.SetB(x-2, y+2, Clip(Bmp[x-2, y+2].B + DiffB * 1));
319 | Bmp.SetB(x-1, y+2, Clip(Bmp[x-1, y+2].B + DiffB * 2));
320 | Bmp.SetB(x , y+2, Clip(Bmp[x , y+2].B + DiffB * 4));
321 | Bmp.SetB(x+1, y+2, Clip(Bmp[x+1, y+2].B + DiffB * 2));
322 | Bmp.SetB(x+2, y+2, Clip(Bmp[x+2, y+2].B + DiffB * 1));
323 | end;
324 |
325 | procedure _burkes(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
326 | //Burkes dithering
327 | var DiffR, DiffG, DiffB: Extended;
328 | begin
329 | if (x < 2) or (x > Bmp.Width-3) or (y > Bmp.Height-2) then Exit;
330 |
331 | DiffR := (1/32) * error.R;
332 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 8));
333 | Bmp.SetR(x+2, y , Clip(Bmp[x+2, y ].R + DiffR * 4));
334 | Bmp.SetR(x-2, y+1, Clip(Bmp[x-2, y+1].R + DiffR * 2));
335 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 4));
336 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 8));
337 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR * 4));
338 | Bmp.SetR(x+2, y+1, Clip(Bmp[x+2, y+1].R + DiffR * 2));
339 |
340 | DiffG := (1/32) * error.G;
341 | Bmp.SetG(x+1, y , Clip(Bmp[x+1, y ].G + DiffG * 8));
342 | Bmp.SetG(x+2, y , Clip(Bmp[x+2, y ].G + DiffG * 4));
343 | Bmp.SetG(x-2, y+1, Clip(Bmp[x-2, y+1].G + DiffG * 2));
344 | Bmp.SetG(x-1, y+1, Clip(Bmp[x-1, y+1].G + DiffG * 4));
345 | Bmp.SetG(x , y+1, Clip(Bmp[x , y+1].G + DiffG * 8));
346 | Bmp.SetG(x+1, y+1, Clip(Bmp[x+1, y+1].G + DiffG * 4));
347 | Bmp.SetG(x+2, y+1, Clip(Bmp[x+2, y+1].G + DiffG * 2));
348 |
349 | DiffB := (1/32) * error.B;
350 | Bmp.SetB(x+1, y , Clip(Bmp[x+1, y ].B + DiffB * 8));
351 | Bmp.SetB(x+2, y , Clip(Bmp[x+2, y ].B + DiffB * 4));
352 | Bmp.SetB(x-2, y+1, Clip(Bmp[x-2, y+1].B + DiffB * 2));
353 | Bmp.SetB(x-1, y+1, Clip(Bmp[x-1, y+1].B + DiffB * 4));
354 | Bmp.SetB(x , y+1, Clip(Bmp[x , y+1].B + DiffB * 8));
355 | Bmp.SetB(x+1, y+1, Clip(Bmp[x+1, y+1].B + DiffB * 4));
356 | Bmp.SetB(x+2, y+1, Clip(Bmp[x+2, y+1].B + DiffB * 2));
357 | end;
358 |
359 | procedure _floyd(Error: TPixInt; x, y: Integer; Bmp: TPV_Bitmap);
360 | //Floyd-Steinberg dithering
361 | var DiffR, DiffG, DiffB: Extended;
362 | begin
363 | if (x < 1) or (x > Bmp.Width-2) or (y > Bmp.Height-2) then Exit;
364 |
365 | DiffR := (1/16) * Error.R;
366 | Bmp.SetR(x+1, y , Clip(Bmp[x+1, y ].R + DiffR * 7) );
367 | Bmp.SetR(x-1, y+1, Clip(Bmp[x-1, y+1].R + DiffR * 3) );
368 | Bmp.SetR(x , y+1, Clip(Bmp[x , y+1].R + DiffR * 5) );
369 | Bmp.SetR(x+1, y+1, Clip(Bmp[x+1, y+1].R + DiffR * 1) );
370 |
371 | DiffG := (1/16) * Error.G;
372 | Bmp.SetG(x+1, y , Clip(Bmp[x+1, y ].G + DiffG * 7) );
373 | Bmp.SetG(x-1, y+1, Clip(Bmp[x-1, y+1].G + DiffG * 3) );
374 | Bmp.SetG(x , y+1, Clip(Bmp[x , y+1].G + DiffG * 5) );
375 | Bmp.SetG(x+1, y+1, Clip(Bmp[x+1, y+1].G + DiffG * 1) );
376 |
377 | DiffB := (1/16) * Error.B;
378 | Bmp.SetB(x+1, y , Clip(Bmp[x+1, y ].B + DiffB * 7) );
379 | Bmp.SetB(x-1, y+1, Clip(Bmp[x-1, y+1].B + DiffB * 3) );
380 | Bmp.SetB(x , y+1, Clip(Bmp[x , y+1].B + DiffB * 5) );
381 | Bmp.SetB(x+1, y+1, Clip(Bmp[x+1, y+1].B + DiffB * 1) );
382 | end;
383 |
384 | procedure ReduceColors(Bmp: TPV_Bitmap; MaxColors: Byte; Dither: TDither);
385 | var ColorQuantizer: TColorQuantizer;
386 | pal: array of TPix;
387 | i: Integer;
388 | x,y: Integer;
389 | P: PPix;
390 | R,G,B: Byte;
391 | Error: TPixInt;
392 | Bits: Byte;
393 | begin
394 | Bits := Ceil(Log2(MaxColors));
395 |
396 | SetLength(pal, 256);
397 |
398 | ColorQuantizer := TColorQuantizer.Create(MaxColors, Bits);
399 | try
400 | ColorQuantizer.ProcessImage(Bmp);
401 | ColorQuantizer.GetColorTable(pal);
402 | finally
403 | ColorQuantizer.Free;
404 | end;
405 |
406 | //Bmp.FBitmap.BeginUpdate(False);
407 |
408 | for y:=0 to Bmp.Height-1 do begin
409 | P := Bmp.Scanline[y];
410 |
411 | for x:=0 to Bmp.Width-1 do begin
412 | BestColor(P^.R, P^.G, P^.B, pal, MaxColors, R,G,B);
413 |
414 | Error.R := P^.R-R;
415 | Error.G := P^.G-G;
416 | Error.B := P^.B-B;
417 |
418 | P^.R := R;
419 | P^.G := G;
420 | P^.B := B;
421 |
422 | case Dither of
423 | ddSierra2 : _Sierra2(Error, x,y, Bmp);
424 | ddSierra3 : _Sierra3(Error, x,y, Bmp);
425 | ddSierra4 : _Sierra4(Error, x,y, Bmp);
426 | ddJarvis : _Jarvis(Error, x,y, Bmp);
427 | ddAtkinson : _Atkinson(Error, x,y, Bmp);
428 | ddStucki : _Stucki(Error, x,y, Bmp);
429 | ddFloyd : _Floyd(Error, x,y, Bmp);
430 | ddBurkes : _Burkes(Error, x,y, Bmp);
431 | end;
432 |
433 | Inc(P);
434 | end;
435 | end;
436 |
437 | //save palette
438 | for i:=0 to MaxColors-1 do
439 | Bmp.AddPal(Pal[i].R, Pal[i].G, Pal[i].B, 255);
440 |
441 | //Bmp.FBitmap.EndUpdate();
442 | end;
443 |
444 | ////////////////////////////////////////////////////////////////////////////////
445 | // Octree Color Quantization Engine
446 | //
447 | // Adapted from GifImage 2.2 (by Anders Melander and others), which was adapted
448 | // from Earl F. Glynn's ColorQuantizationLibrary
449 | ////////////////////////////////////////////////////////////////////////////////
450 |
451 | constructor TOctreeNode.Create(Level: integer; ColorBits: integer;
452 | var LeafCount: integer; var ReducibleNodes: TReducibleNodes);
453 | var i: Integer;
454 | begin
455 | PixelCount := 0;
456 | SumR := 0;
457 | SumG := 0;
458 | SumB := 0;
459 |
460 | for i := Low(Child) to High(Child) do Child[i] := nil;
461 |
462 | IsLeaf := (Level = ColorBits);
463 |
464 | if (IsLeaf) then begin
465 | Next := nil;
466 | inc(LeafCount);
467 | end
468 | else begin
469 | Next := ReducibleNodes[Level];
470 | ReducibleNodes[Level] := self;
471 | end;
472 | end;
473 |
474 | destructor TOctreeNode.Destroy;
475 | var i: Integer;
476 | begin
477 | for i := High(Child) downto Low(Child) do
478 | Child[i].Free;
479 | end;
480 |
481 | constructor TColorQuantizer.Create(MaxColors: integer; ColorBits: integer);
482 | var i: Integer;
483 | begin
484 | ASSERT(ColorBits <= 8, 'ColorBits must be 8 or less');
485 |
486 | FTree := nil;
487 | FLeafCount := 0;
488 |
489 | // Initialize all nodes even though only ColorBits+1 of them are needed
490 | for i := Low(FReducibleNodes) to High(FReducibleNodes) do
491 | FReducibleNodes[i] := nil;
492 |
493 | FMaxColors := MaxColors;
494 | FColorBits := ColorBits;
495 | end;
496 |
497 | destructor TColorQuantizer.Destroy;
498 | begin
499 | if (FTree <> nil) then
500 | DeleteTree(FTree);
501 | end;
502 |
503 | procedure TColorQuantizer.GetColorTable(var RGBQuadArray: TPalArray);
504 | var Index: Integer;
505 | begin
506 | Index := 0;
507 | GetPaletteColors(FTree, RGBQuadArray, Index);
508 | end;
509 |
510 | function TColorQuantizer.ProcessImage(const Bmp: TPV_Bitmap): boolean;
511 | var i,j: Integer;
512 | P: PPix;
513 | begin
514 | Result := True;
515 |
516 | for j := 0 to Bmp.Height-1 do begin
517 | P := Bmp.Scanline[j];
518 |
519 | for i:=0 to Bmp.Width-1 do begin
520 | AddColor(FTree, P^.R, P^.G, P^.B, FColorBits, 0, FLeafCount, FReducibleNodes);
521 |
522 | while FLeafCount > FMaxColors do ReduceTree(FColorbits, FLeafCount, FReducibleNodes);
523 | inc(P);
524 | end;
525 | end;
526 | end;
527 |
528 | procedure TColorQuantizer.AddColor(var Node: TOctreeNode; r,g,b: byte;
529 | ColorBits: integer; Level: integer; var LeafCount: integer;
530 | var ReducibleNodes: TReducibleNodes);
531 | const Mask: array[0..7] of BYTE = ($80, $40, $20, $10, $08, $04, $02, $01);
532 | var Index, Shift: Integer;
533 | begin
534 | // If the node doesn't exist, create it.
535 | if (Node = nil) then
536 | Node := TOctreeNode.Create(Level, ColorBits, LeafCount, ReducibleNodes);
537 |
538 | if (Node.IsLeaf) then begin
539 | inc(Node.PixelCount);
540 | inc(Node.SumR, r);
541 | inc(Node.SumG, g);
542 | inc(Node.SumB, b);
543 | end
544 | else begin
545 | // Recurse a level deeper if the node is not a leaf.
546 | Shift := 7 - Level;
547 |
548 | Index := (((r and mask[Level]) SHR Shift) SHL 2) or
549 | (((g and mask[Level]) SHR Shift) SHL 1) or
550 | ((b and mask[Level]) SHR Shift);
551 | AddColor(Node.Child[Index], r, g, b, ColorBits, Level+1, LeafCount, ReducibleNodes);
552 | end;
553 | end;
554 |
555 | procedure TColorQuantizer.DeleteTree(var Node: TOctreeNode);
556 | var i: Integer;
557 | begin
558 | for i := High(TReducibleNodes) downto Low(TReducibleNodes) do
559 | if (Node.Child[i] <> nil) then
560 | DeleteTree(Node.Child[i]);
561 |
562 | Node.Free;
563 | Node := nil;
564 | end;
565 |
566 | procedure TColorQuantizer.GetPaletteColors(const Node: TOctreeNode;
567 | var RGBQuadArray: TPalArray; var Index: integer);
568 | var i: integer;
569 | begin
570 | if (Node.IsLeaf) then begin
571 | with RGBQuadArray[Index] do begin
572 | if (Node.PixelCount <> 0) then begin
573 | R := BYTE(Node.SumR DIV Node.PixelCount);
574 | G := BYTE(Node.SumG DIV Node.PixelCount);
575 | B := BYTE(Node.SumB DIV Node.PixelCount);
576 | end
577 | else begin
578 | R := 0;
579 | G := 0;
580 | B := 0;
581 | end;
582 | A := 0;
583 | end;
584 | inc(Index);
585 | end
586 | else begin
587 | for i := Low(Node.Child) to High(Node.Child) do
588 | if (Node.Child[i] <> nil) then
589 | GetPaletteColors(Node.Child[i], RGBQuadArray, Index);
590 | end;
591 | end;
592 |
593 | procedure TColorQuantizer.ReduceTree(ColorBits: integer; var LeafCount: integer;
594 | var ReducibleNodes: TReducibleNodes);
595 | var SumR, SumG, SumB: Integer;
596 | Children: Integer;
597 | i: Integer;
598 | Node: TOctreeNode;
599 | begin
600 | // Find the deepest level containing at least one reducible node
601 | i := Colorbits - 1;
602 | while (i > 0) and (ReducibleNodes[i] = nil) do
603 | dec(i);
604 |
605 | // Reduce the node most recently added to the list at level i.
606 | Node := ReducibleNodes[i];
607 | ReducibleNodes[i] := Node.Next;
608 |
609 | SumR := 0;
610 | SumG := 0;
611 | SumB := 0;
612 | Children := 0;
613 |
614 | for i := Low(ReducibleNodes) to High(ReducibleNodes) do
615 | if (Node.Child[i] <> nil) then begin
616 | inc(SumR, Node.Child[i].SumR);
617 | inc(SumG, Node.Child[i].SumG);
618 | inc(SumB, Node.Child[i].SumB);
619 | inc(Node.PixelCount, Node.Child[i].PixelCount);
620 | Node.Child[i].Free;
621 | Node.Child[i] := nil;
622 | inc(Children);
623 | end;
624 |
625 | Node.IsLeaf := TRUE;
626 | Node.SumR := SumR;
627 | Node.SumG := SumG;
628 | Node.SumB := SumB;
629 | dec(LeafCount, Children-1);
630 | end;
631 |
632 | end.
633 |
--------------------------------------------------------------------------------
/PV_Streams.pas:
--------------------------------------------------------------------------------
1 | unit PV_Streams;
2 |
3 | //Lazzy Image Viewer
4 | //github.com/PascalVault
5 | //License: MIT
6 |
7 | interface
8 |
9 | uses Classes, SysUtils, Dialogs;
10 |
11 | type
12 | { TPV_Reader }
13 |
14 | TPV_Reader = class
15 | private
16 | FStream: TStream;
17 | FSize: Integer;
18 | Buf: array of Byte;
19 | FPos: Integer;
20 |
21 | procedure SetOffset(Offset: Integer);
22 | function GetOffset: Integer;
23 | procedure SetAtLeast(Amount: Integer);
24 | public
25 | function GetU: Byte; inline;
26 | function GetU2: Word; inline;
27 | function GetU3: Cardinal; inline;
28 | function GetU4: Cardinal; inline;
29 |
30 | function GetMU2: Word; inline;
31 | function GetMU4: Cardinal; inline;
32 |
33 | function GetI: ShortInt; inline;
34 | function GetI2: Smallint; inline;
35 | function GetI4: LongInt; inline;
36 | function GetMI2: Smallint; inline;
37 | function GetMI4: LongInt; inline;
38 |
39 | function GetF: Single; inline;
40 | function GetMF: Single; inline; //Single
41 | function GetV: Int64; inline; //variable-length integer
42 |
43 | function GetLn(UntilCh: String = ''): String;
44 |
45 | property Offset: Integer read GetOffset write SetOffset;
46 | property AtLeast: Integer write SetAtLeast;
47 | property Size: Integer read FSize;
48 |
49 | function Get(var Buffer; Count: Longint): Longint;
50 | function GetC: Char; inline;
51 | function GetNum: Integer;
52 | function GetWhite: String;
53 | function GetS(Count: Integer = -1): String;
54 | procedure Skip(Count: Integer);
55 | constructor Create(Str: TStream; Length: Integer = -1);
56 | end;
57 |
58 | { TPV_Writer }
59 | TPV_Writer = class
60 | private
61 | FStream: TStream;
62 | Buf: array of Byte;
63 | FPos: Integer;
64 | FSize: Integer;
65 | public
66 | procedure Flush;
67 |
68 | procedure Put(const Buffer; Count: Integer);
69 | procedure PutU(V: Byte); inline;
70 | procedure PutU2(V: Word); inline;
71 | procedure PutU4(V: Cardinal); inline;
72 | procedure PutMU2(V: Word); inline;
73 | procedure PutMU4(V: Cardinal); inline;
74 |
75 | procedure PutI(V: ShortInt); inline;
76 | procedure PutI2(V: Smallint); inline;
77 | procedure PutI4(V: LongInt); inline;
78 | procedure PutMI2(V: Smallint); inline;
79 | procedure PutMI4(V: LongInt); inline;
80 |
81 | procedure PutMF(V: Single); inline;
82 | procedure PutF(V: Single); inline;
83 |
84 | procedure PutV(V: Word); inline;
85 |
86 | procedure Skip(Len: Integer);
87 |
88 | procedure PutS(S: String); inline;
89 | procedure CopyFrom(Str: TStream; Count: Integer);
90 |
91 | constructor Create(Str: TStream);
92 | destructor Destroy; override;
93 | end;
94 |
95 | function Getbits(Val: Word; Index, Count: Integer): Word;
96 |
97 | implementation
98 |
99 | function Getbits(Val: Word; Index, Count: Integer): Word;
100 | var Res: Word;
101 | begin
102 | Res := Val shr Index;
103 | case Count of
104 | 0: Result := 0;
105 | 1: Result := Res and 1;
106 | 2: Result := Res and 3;
107 | 3: Result := Res and 7;
108 | 4: Result := Res and 15;
109 | 5: Result := Res and 31;
110 | 6: Result := Res and 63;
111 | 7: Result := Res and 127;
112 |
113 | 8: Result := Res and 255;
114 | 9: Result := Res and 511;
115 | 10: Result := Res and 1023;
116 | 11: Result := Res and 2047;
117 | 12: Result := Res and 4095;
118 | 13: Result := Res and 8191;
119 | 14: Result := Res and 16383;
120 | 15: Result := Res and 32767;
121 | end;
122 | end;
123 |
124 | { TPV_Reader }
125 |
126 | procedure TPV_Reader.SetOffset(Offset: Integer);
127 | begin
128 | FPos := Offset;
129 | end;
130 |
131 | function TPV_Reader.GetOffset: Integer;
132 | begin
133 | Result := FPos;
134 | end;
135 |
136 | procedure TPV_Reader.SetAtLeast(Amount: Integer);
137 | begin
138 | if FSize-FPos < Amount then SetLength(Buf, FPos+Amount);
139 | end;
140 |
141 | function TPV_Reader.GetU: Byte;
142 | begin
143 | Result := Buf[FPos];
144 | Inc(FPos);
145 | end;
146 |
147 | function TPV_Reader.GetU2: Word;
148 | begin
149 | Move(Buf[FPos], Result, 2);
150 | Inc(FPos, 2);
151 | end;
152 |
153 | function TPV_Reader.GetU3: Cardinal;
154 | begin
155 | Move(Buf[FPos], Result, 3);
156 | Inc(FPos, 3);
157 | end;
158 |
159 | function TPV_Reader.GetU4: Cardinal;
160 | begin
161 | Move(Buf[FPos], Result, 4);
162 | Inc(FPos, 4);
163 | end;
164 |
165 | function TPV_Reader.GetMU2: Word;
166 | begin
167 | Move(Buf[FPos], Result, 2);
168 |
169 | Result := SwapEndian(Result);
170 | Inc(FPos, 2);
171 | end;
172 |
173 | function TPV_Reader.GetMU4: Cardinal;
174 | begin
175 | Move(Buf[FPos], Result, 4);
176 |
177 | Result := SwapEndian(Result);
178 | Inc(FPos, 4);
179 | end;
180 |
181 | function TPV_Reader.GetI: ShortInt;
182 | begin
183 | Move(Buf[FPos], Result, 1);
184 | Inc(FPos);
185 | end;
186 |
187 | function TPV_Reader.GetI2: Smallint;
188 | begin
189 | Move(Buf[FPos], Result, 2);
190 | Inc(FPos, 2);
191 | end;
192 |
193 | function TPV_Reader.GetI4: LongInt;
194 | begin
195 | Move(Buf[FPos], Result, 4);
196 | Inc(FPos, 4);
197 | end;
198 |
199 | function TPV_Reader.GetMI2: Smallint;
200 | begin
201 | Move(Buf[FPos], Result, 2);
202 |
203 | Result := SwapEndian(Result);
204 | Inc(FPos, 2);
205 | end;
206 |
207 | function TPV_Reader.GetMI4: LongInt;
208 | begin
209 | Move(Buf[FPos], Result, 4);
210 |
211 | Result := SwapEndian(Result);
212 | Inc(FPos, 4);
213 | end;
214 |
215 | function TPV_Reader.GetF: Single;
216 | var Temp: Cardinal absolute Result;
217 | begin
218 | Move(Buf[FPos], Temp, 4);
219 |
220 | Inc(FPos, 4);
221 | end;
222 |
223 | function TPV_Reader.GetMF: Single;
224 | var Temp: Cardinal absolute Result;
225 | begin
226 | Move(Buf[FPos], Temp, 4);
227 |
228 | Temp := SwapEndian(Temp);
229 |
230 | Inc(FPos, 4);
231 | end;
232 |
233 | function TPV_Reader.GetV: Int64;
234 | var i: Integer;
235 | Val,Cont: Byte;
236 | V: Byte;
237 | begin
238 | Result := 0;
239 |
240 | while True do begin
241 | V := Buf[FPos];
242 | Inc(FPos);
243 |
244 | Cont := V shr 7;
245 | Val := V and $7F;
246 |
247 | Result := (Result shl 7) + Val;
248 |
249 | if Cont=0 then Exit;
250 | end;
251 | end;
252 |
253 | function TPV_Reader.GetLn(UntilCh: String): String;
254 | var A,B: Integer;
255 | Count: Integer;
256 | i: Integer;
257 | begin
258 | if UntilCh = '' then begin
259 | Count := 10000;
260 | if Count > FSize-FPos then Count := FSize-FPos;
261 |
262 | SetLength(Result, Count);
263 | Move(Buf[FPos], Result[1], Count);
264 |
265 | A := 0;
266 | for i:=1 to Length(Result) do
267 | if (Result[i] = #13) or (Result[i] = #10) then begin
268 | A := i;
269 | break;
270 | end;
271 |
272 | Result := Copy(Result, 1, A-1);
273 | Inc(FPos, A);
274 | Exit;
275 | end;
276 |
277 | Count := 10000;
278 | if Count > FSize-FPos then Count := FSize-FPos;
279 |
280 | SetLength(Result, Count);
281 | Move(Buf[FPos], Result[1], Count);
282 |
283 | A := Pos(UntilCh, Result);
284 |
285 | Result := Copy(Result, 1, A-1);
286 | Inc(FPos, A);
287 | Exit;
288 | end;
289 |
290 | function TPV_Reader.GetC: Char;
291 | begin
292 | Result := chr(Buf[FPos]);
293 | Inc(FPos);
294 | end;
295 |
296 | function TPV_Reader.Get(var Buffer; Count: Longint): Longint;
297 | var Count2: Integer;
298 | i: Integer;
299 | begin
300 | Count2 := FSize-FPos;
301 | if Count2 < Count then Count := Count2;
302 |
303 | Move(Buf[FPos], Buffer, Count);
304 |
305 | Result := Count;
306 | Inc(FPos, Count);
307 | end;
308 |
309 | function TPV_Reader.GetNum: Integer;
310 | var Res: String;
311 | begin
312 | Res := '';
313 |
314 | while FPos < FSize do begin
315 | if Buf[FPos] in [48..57] then Res := Res + chr(Buf[FPos])
316 | else break;
317 |
318 | Inc(FPos);
319 | end;
320 |
321 | Result := StrToInt64Def(Res, 0);
322 | end;
323 |
324 | function TPV_Reader.GetWhite: String;
325 | begin
326 | Result := '';
327 |
328 | while FPos < FSize do begin
329 | if Buf[FPos] in [32,13,10,09] then Result := Result + chr(Buf[FPos])
330 | else break;
331 |
332 | Inc(FPos);
333 | end;
334 | end;
335 |
336 | function TPV_Reader.GetS(Count: Integer): String;
337 | begin
338 | if Count = -1 then Count := FSize;
339 |
340 | SetLength(Result, Count);
341 | Move(Buf[FPos], Result[1], Count);
342 | Inc(FPos, Count);
343 | end;
344 |
345 | procedure TPV_Reader.Skip(Count: Integer);
346 | begin
347 | Inc(FPos, Count);
348 | end;
349 |
350 | constructor TPV_Reader.Create(Str: TStream; Length: Integer);
351 | begin
352 | FStream := Str;
353 |
354 | if Length = -1 then FSize := Str.Size
355 | else FSize := Length;
356 |
357 | SetLength(Buf, FSize);
358 | Str.Read(Buf[0], FSize);
359 |
360 | FPos := 0;
361 | end;
362 |
363 | { TPV_Writer }
364 |
365 | procedure TPV_Writer.Flush;
366 | begin
367 | if FPos < 1 then Exit;
368 |
369 | FStream.Write(Buf[0], FPos);
370 | FPos := 0;
371 | end;
372 |
373 | procedure TPV_Writer.Put(const Buffer; Count: Integer);
374 | begin
375 | if FPos+Count > FSize then Flush;
376 |
377 | Move(Buffer, Buf[FPos], Count);
378 | Inc(FPos, Count);
379 | end;
380 |
381 | procedure TPV_Writer.PutU(V: Byte);
382 | begin
383 | if FPos+1 > FSize then Flush;
384 |
385 | Buf[FPos] := V;
386 | Inc(FPos);
387 | end;
388 |
389 | procedure TPV_Writer.PutU2(V: Word);
390 | begin
391 | if FPos+2 > FSize then Flush;
392 |
393 | Move(V, Buf[FPos], 2);
394 | Inc(FPos, 2);
395 | end;
396 |
397 | procedure TPV_Writer.PutU4(V: Cardinal);
398 | begin
399 | if FPos+4 > FSize then Flush;
400 |
401 | Move(V, Buf[FPos], 4);
402 | Inc(FPos, 4);
403 | end;
404 |
405 | procedure TPV_Writer.PutMU2(V: Word);
406 | begin
407 | if FPos+2 > FSize then Flush;
408 |
409 | V := SwapEndian(V);
410 |
411 | Move(V, Buf[FPos], 2);
412 | Inc(FPos, 2);
413 | end;
414 |
415 | procedure TPV_Writer.PutMU4(V: Cardinal);
416 | begin
417 | if FPos+4 > FSize then Flush;
418 |
419 | V := SwapEndian(V);
420 |
421 | Move(V, Buf[FPos], 4);
422 | Inc(FPos, 4);
423 | end;
424 |
425 | procedure TPV_Writer.PutI(V: ShortInt);
426 | begin
427 | if FPos+1 > FSize then Flush;
428 |
429 | Move(V, Buf[FPos], 1);
430 | Inc(FPos, 1);
431 | end;
432 |
433 | procedure TPV_Writer.PutI2(V: Smallint);
434 | begin
435 | if FPos+2 > FSize then Flush;
436 |
437 | Move(V, Buf[FPos], 2);
438 | Inc(FPos, 2);
439 | end;
440 |
441 | procedure TPV_Writer.PutI4(V: LongInt);
442 | begin
443 | if FPos+4 > FSize then Flush;
444 |
445 | Move(V, Buf[FPos], 4);
446 | Inc(FPos, 4);
447 | end;
448 |
449 | procedure TPV_Writer.PutMI2(V: Smallint);
450 | begin
451 | if FPos+2 > FSize then Flush;
452 |
453 | V := SwapEndian(V);
454 |
455 | Move(V, Buf[FPos], 2);
456 | Inc(FPos, 2);
457 | end;
458 |
459 | procedure TPV_Writer.PutMI4(V: LongInt);
460 | begin
461 | if FPos+4 > FSize then Flush;
462 |
463 | V := SwapEndian(V);
464 |
465 | Move(V, Buf[FPos], 4);
466 | Inc(FPos, 4);
467 | end;
468 |
469 | procedure TPV_Writer.PutMF(V: Single);
470 | var VV: Cardinal;
471 | begin
472 | if FPos+4 > FSize then Flush;
473 |
474 | Move(V, VV, 4);
475 |
476 | VV := SwapEndian(VV);
477 |
478 | Move(VV, Buf[FPos], 4);
479 | Inc(FPos, 4);
480 | end;
481 |
482 | procedure TPV_Writer.PutF(V: Single);
483 | var VV: Cardinal;
484 | begin
485 | if FPos+4 > FSize then Flush;
486 |
487 | Move(V, VV, 4);
488 |
489 | Move(VV, Buf[FPos], 4);
490 | Inc(FPos, 4);
491 | end;
492 |
493 | procedure TPV_Writer.PutV(V: Word);
494 | var A,B: Byte;
495 | begin
496 | //not really variable-length
497 | A := (V shr 7) + $80;
498 | B := (V and $7F);
499 |
500 | PutU(A);
501 | PutU(B);
502 | end;
503 |
504 | procedure TPV_Writer.Skip(Len: Integer);
505 | var i: Integer;
506 | begin
507 | for i:=0 to Len-1 do
508 | PutU(0);
509 | end;
510 |
511 | procedure TPV_Writer.PutS(S: String);
512 | var Len: Integer;
513 | begin
514 | Len := Length(S);
515 | if FPos+Len > FSize then Flush;
516 |
517 | Move(S[1], Buf[FPos], Len);
518 | Inc(FPos, Len);
519 | end;
520 |
521 | procedure TPV_Writer.CopyFrom(Str: TStream; Count: Integer);
522 | var Buff: array of Byte;
523 | BuffSize: Integer;
524 | Len: Integer;
525 | begin
526 | Flush;
527 | FPos := 0;
528 |
529 | BuffSize := 40960;
530 |
531 | if BuffSize > Count then BuffSize := Count;
532 | SetLength(Buff, BuffSize);
533 |
534 | while Count >0 do begin
535 | Len := Str.Read(Buff[0], BuffSize);
536 |
537 | FStream.Write(Buff[0], Len);
538 | Dec(Count, Len);
539 | end;
540 | end;
541 |
542 | constructor TPV_Writer.Create(Str: TStream);
543 | begin
544 | FStream := Str;
545 | FPos := 0;
546 | FSize := 409600;
547 | SetLength(Buf, FSize);
548 | end;
549 |
550 | destructor TPV_Writer.Destroy;
551 | begin
552 | Flush;
553 |
554 | inherited Destroy;
555 | end;
556 |
557 | end.
558 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # Lazzy_Image_Viewer
2 | Image viewer in Pascal. Supports 100+ image formats
3 |
4 |
5 |
6 | 
7 |
8 | 
9 |
--------------------------------------------------------------------------------
/RLE.pas:
--------------------------------------------------------------------------------
1 | {
2 |
3 |
4 | procedure UnRle4BT(source: TQFile; out dest: TQFile; packedSize: Integer);
5 | const unitSize = 1;
6 | var i, k: Integer;
7 | count: Integer;
8 | val: Byte;
9 | begin
10 | i := 0;
11 | while (i 173) then begin //uncompressed
14 | dest.writeU(count);
15 | inc(i, unitSize);
16 | end
17 | else begin
18 | count := source.readU;
19 | val := source.readU;
20 | for k:=0 to count-1 do dest.writeU(val);
21 | inc(i, unitSize+1);
22 | end;
23 | end;
24 | end;
25 |
26 |
27 | procedure UnRleBMP8(source: TQFile; out dest: TQFile; packedSize: Integer; width, height: Integer);
28 | var i: Integer;
29 | x,y: Integer;
30 | count, marker: Integer;
31 | byt: Byte;
32 |
33 | procedure moveXY(newX, newY: Integer);
34 | begin
35 | dest.position := (newX - x) + (newY - y)*width;
36 | x := newX;
37 | y := newY;
38 | end;
39 |
40 | begin
41 | i := 0;
42 | x := 0;
43 | y := 0;
44 |
45 | dest.writeRepeat(0, width*height);
46 | dest.position := 0;
47 |
48 | while (i 0) then begin //RLE-compressed
52 | dest.copyRepeat(source, 1, count);
53 | inc(i, 2);
54 | inc(x, count);
55 | end
56 | else begin //uncompressed
57 | marker := source.readU;
58 |
59 | if marker = 0 then begin //end of scanline
60 | moveXY(0, y+1);
61 | inc(i, 1);
62 | end
63 | else if marker = 1 then begin //EOF
64 | break;
65 | end
66 | else if marker = 2 then begin //move X,Y
67 | moveXY(x+source.readU, y+source.readU);
68 | end
69 | else begin //uncompressed
70 | dest.writeRepeat(byt, marker); //TODO: skad byt?
71 |
72 | if marker mod 2 = 1 then source.readU; //padding byte
73 | end;
74 | end;
75 | end;
76 | end;
77 | }
78 |
79 |
80 | procedure UnRle_LBM(src: TStream; dest: TStream; packedSize: Integer);
81 | const unitSize = 1;
82 | var i,j: Integer;
83 | count: Byte;
84 | count2: ShortInt absolute count;
85 | buff: array of Byte;
86 | begin
87 | setLength(Buff, unitSize);
88 |
89 | i := 0;
90 | while (i= 0) then begin //uncompressed
94 | count2 := count2+1;
95 | dest.copyFrom(src, unitSize*count2);
96 | inc(i, unitSize*count2+1);
97 | end
98 | else if count2 = -128 then begin
99 | inc(i, 1);
100 | end
101 | else begin
102 | count2 := -count2+1;
103 |
104 | Src.Read(buff[0], unitSize);
105 | for j:=0 to count2-1 do
106 | Dest.Write(Buff[0], unitSize);
107 |
108 | inc(i, unitSize+1);
109 | end;
110 | end;
111 | end;
112 |
113 | procedure UnRle_PGC(src: TStream; dest: TStream; packedSize: Integer);
114 | const unitSize = 1;
115 | var i,j: Integer;
116 | count: Integer;
117 | buff: array of Byte;
118 | begin
119 | setLength(Buff, unitSize);
120 |
121 | i := 0;
122 | while (i 9000 then break; //TODO: rather uncecessray
153 |
154 | count := src.ReadByte;
155 | if (count < 128) then begin
156 | count := count;
157 | if count = 0 then begin
158 | count := SwapEndian(src.ReadWord);
159 | inc(i, 2);
160 | end;
161 |
162 | Src.Read(buff[0], unitSize);
163 | for j:=0 to count-1 do
164 | Dest.Write(Buff[0], unitSize);
165 |
166 | inc(i, unitSize+1);
167 | end
168 | else begin //uncompressed
169 | count := count-128;
170 | if count = 0 then begin
171 | count := SwapEndian(src.ReadWord);
172 | inc(i, 2);
173 | end;
174 |
175 | dest.copyFrom(src, unitSize*count);
176 | inc(i, unitSize*count+1);
177 | end;
178 | end;
179 | end;
180 |
181 |
182 | procedure Unrle_PAC(Src: TStream; Dest: TStream; idByte, packByte, specialByte: Byte);
183 | var count: Integer;
184 | i: Integer;
185 | b: Byte;
186 | begin
187 | while (Src.position < Src.size) do begin
188 | b := Src.ReadByte;
189 |
190 | if b = idByte then begin
191 | count := Src.ReadByte;
192 |
193 | for i:=0 to count do begin
194 | Dest.Write(packByte, 1);
195 | end;
196 |
197 | end
198 | else if b = specialByte then begin
199 | b := Src.ReadByte;
200 | count := Src.ReadByte;
201 |
202 | for i:=0 to count do begin //or maybe count-1
203 | Dest.Write(b, 1);
204 | end;
205 | end
206 | else begin
207 | Dest.Write(b, 1);
208 | end;
209 | end;
210 | end;
211 |
212 | procedure Unrle_TGA(Src: TStream; Dest: TStream; packedSize: Integer; unitSize: Integer);
213 | var i,j,k: Integer;
214 | A,B,C: Byte;
215 | count: Integer;
216 | Buff: array of Byte;
217 | begin
218 | i := 0;
219 | SetLength(Buff, unitSize);
220 |
221 | while i 128 then begin //uncompressed
261 |
262 | count := count-128; //+1
263 |
264 | for k:=0 to count-1 do begin
265 | Src.Read(Buff[0], unitSize);
266 | Dest.Write(Buff[0], unitSize);
267 | end;
268 |
269 | Inc(i, unitSize*count+1);
270 | end
271 | else begin
272 | count := count;//+1
273 | Src.Read(Buff[0], unitSize);
274 |
275 | for k:=0 to count-1 do begin
276 | Dest.Write(Buff[0], unitSize);
277 | end;
278 | Inc(i, unitSize+1);
279 | end;
280 | end;
281 | end;
282 |
283 | procedure Unrle_PCX(Src: TStream; Dest: TStream; packedSize: Integer);
284 | var i,j,k: Integer;
285 | A,B,C: Byte;
286 | buff: Byte;
287 | count: Integer;
288 | begin
289 | i := 0;
290 | j := 0;
291 |
292 | while i 127 then count := count - 256; //convert UInt8 to Int8;
428 |
429 | if count = -128 then Inc(i)
430 | else if count >=0 then begin //uncompressed
431 | count := count+1;
432 |
433 | for k:=0 to count-1 do begin
434 | Src.Read(Buff[0], unitSize);
435 | Dest.Write(Buff[0], unitSize);
436 | end;
437 |
438 | Inc(i, unitSize*count+1);
439 | end
440 | else begin
441 | count := -1*count+1;
442 |
443 | Src.Read(Buff[0], unitSize);
444 |
445 | for k:=0 to count-1 do begin
446 | Dest.Write(Buff[0], unitSize);
447 | end;
448 | Inc(i, unitSize+1);
449 | end;
450 | end;
451 | end;
452 |
453 | function hexInt(hex: String): Integer;
454 | begin
455 | Result := StrToInt64Def('$' + hex, 0);
456 | end;
457 |
458 |
--------------------------------------------------------------------------------
/dlg_about.lfm:
--------------------------------------------------------------------------------
1 | object AboutDlg: TAboutDlg
2 | Left = 627
3 | Height = 313
4 | Top = 385
5 | Width = 461
6 | Caption = 'About'
7 | ClientHeight = 313
8 | ClientWidth = 461
9 | Color = clWhite
10 | LCLVersion = '3.0.0.3'
11 | object Image1: TImage
12 | Left = 72
13 | Height = 28
14 | Top = 32
15 | Width = 316
16 | AutoSize = True
17 | Picture.Data = {
18 | 07544269746D61709E040000424D9E040000000000003E000000280000003C01
19 | 00001C000000010001000000000000000000C30E0000C30E0000000000000000
20 | 000000000000FFFFFF00FFFFFFFFFFFFFFFFFFFF8007FFFFFFFFFFFFFFFFE001
21 | FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF8007FFFF
22 | FFFFFFFFFFFFE001FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFF
23 | FFFFFFFF8001FFFFFFFFFFFFFFFFE0007FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
24 | FFF0FFFFFFFFFFFFFFFFFFFF8001FFFFFFFFFFFFFFFFE0007FFFFFFFFFFFFFFF
25 | FFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFE1FFFFFFFFFFFFFFFFFFF8
26 | 7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFE1FFFF
27 | FFFFFFFFFFFFFFF87FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF08001FE001F80
28 | 01F8001FFFE1FFFE1F86187F8007FFF87F8007FFFFE7FF87F8007F8001FE001F
29 | 87F08001FE001F8001F8001FFFE1FFFE1F86187F8007FFF87F8007FFFFE7FF87
30 | F8007F8001FE001F87F08001F8001F8001F8001FE001FFFE1F86187E0007F800
31 | 7E0007FFFF81FF87E0007E0001F8001F87F08001F8001F8001F8001FE001FFFE
32 | 1F86187E0007F8007E0007FFFF81FF87E0007E0001F8001F87F087FFF87E1F81
33 | FFF81FFF8001FFFE1F86187E1F87E0007E1FFFFFFE007F87E1FFFE1861F87FFF
34 | 87F087FFF87E1F81FFF81FFF8001FFFE1F86187E1F87E0007E1FFFFFFE007F87
35 | E1FFFE1861F87FFF87F087FFF87E1FE07FFE07FF87E1FFFE1F86187E1F87E1F8
36 | 7E001FFFF8181F87E001FE1861F8007F87F087FFF87E1FE07FFE07FF87E1FFFE
37 | 1F86187E1F87E1F87E001FFFF8181F87E001FE1861F8007F87F087FFF8001FF8
38 | 1FFF81FF87E1FFFE1F86187E0007E1F87E0007FFF87E1F87E0007E1861F8001F
39 | 87F087FFF8001FF81FFF81FF87E1FFFE1F86187E0007E1F87E0007FFF87E1F87
40 | E0007E1861F8001F87F087FFFE001FFE07FFE07F87E1FFFE1F86187F8007E1F8
41 | 7E1F87FFF87E1F87E1F87E1861F87E1F87F087FFFE001FFE07FFE07F87E1FFFE
42 | 1F86187F8007E1F87E1F87FFF87E1F87E1F87E1861F87E1F87F087FFFFFE1FFF
43 | 81FFF81F87E1FFFE1F86187FFF87E1F87E1F87FFF87E1F87E1F87E1861F87E1F
44 | 81F087FFFFFE1FFF81FFF81F87E1FFFE1F86187FFF87E1F87E1F87FFF87E1F87
45 | E1F87E1861F87E1F81F087FFFE001F8001F8001F87E1FFFE1F80007F8007E000
46 | 7E0007FFF87E1F87E0007E1FE1F8001F801087FFFE001F8001F8001F87E1FFFE
47 | 1F80007F8007E0007E0007FFF87E1F87E0007E1FE1F8001F801087FFFE007F80
48 | 01F8001F87E1FFFE1F8001FF801FF801FF801FFFF87E1FFFF801FE1FE1FE007F
49 | 861087FFFE007F8001F8001F87E1FFFE1F8001FF801FF801FF801FFFF87E1FFF
50 | F801FE1FE1FE007F861087FFFFFFFFFFFFFFFFFFFFFFFFFE1FFFFFFFFFFFFFFF
51 | FFFFFFFFF87E1F87FFFFFFFFFFFFFFFFFFF087FFFFFFFFFFFFFFFFFFFFFFFFFE
52 | 1FFFFFFFFFFFFFFFFFFFFFFFF87E1F87FFFFFFFFFFFFFFFFFFF087FFFFFFFFFF
53 | FFFFFFFFFFFFFFFE1FFFFFFFFFFFFFFFFFFFFFFFF87E1F87FFFFFFFFFFFFFFFF
54 | FFF087FFFFFFFFFFFFFFFFFFFFFFFFFE1FFFFFFFFFFFFFFFFFFFFFFFF87E1F87
55 | FFFFFFFFFFFFFFFFFFF0
56 | }
57 | end
58 | object Label1: TLabel
59 | Left = 360
60 | Height = 15
61 | Top = 64
62 | Width = 65
63 | Caption = 'version 0.7.1'
64 | end
65 | object Memo1: TMemo
66 | Left = 32
67 | Height = 200
68 | Top = 96
69 | Width = 398
70 | Lines.Strings = (
71 | 'Copyright (c) 2024 by PascalVault'
72 | ''
73 | 'License: GNU/GPL'
74 | ''
75 | 'Icons: Farm Fresh'
76 | )
77 | TabOrder = 0
78 | end
79 | end
80 |
--------------------------------------------------------------------------------
/dlg_about.pas:
--------------------------------------------------------------------------------
1 | unit dlg_about;
2 |
3 | //Lazzy Image Viewer
4 | //github.com/PascalVault
5 | //License: GNU/GPL
6 |
7 | {$mode ObjFPC}{$H+}
8 |
9 | interface
10 |
11 | uses
12 | Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls;
13 |
14 | type
15 |
16 | { TAboutDlg }
17 |
18 | TAboutDlg = class(TForm)
19 | Image1: TImage;
20 | Label1: TLabel;
21 | Memo1: TMemo;
22 | private
23 |
24 | public
25 |
26 | end;
27 |
28 | var
29 | AboutDlg: TAboutDlg;
30 |
31 | implementation
32 |
33 | {$R *.lfm}
34 |
35 | end.
36 |
37 |
--------------------------------------------------------------------------------
/dlg_colors.lfm:
--------------------------------------------------------------------------------
1 | object ColorsDlg: TColorsDlg
2 | Left = 540
3 | Height = 233
4 | Top = 548
5 | Width = 424
6 | Caption = 'Colors'
7 | ClientHeight = 233
8 | ClientWidth = 424
9 | LCLVersion = '3.0.0.3'
10 | object RadioGroup1: TRadioGroup
11 | Left = 168
12 | Height = 208
13 | Top = 16
14 | Width = 129
15 | AutoFill = True
16 | Caption = 'Dithering'
17 | ChildSizing.LeftRightSpacing = 6
18 | ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
19 | ChildSizing.EnlargeVertical = crsHomogenousChildResize
20 | ChildSizing.ShrinkHorizontal = crsScaleChilds
21 | ChildSizing.ShrinkVertical = crsScaleChilds
22 | ChildSizing.Layout = cclLeftToRightThenTopToBottom
23 | ChildSizing.ControlsPerLine = 1
24 | ClientHeight = 188
25 | ClientWidth = 125
26 | ItemIndex = 1
27 | Items.Strings = (
28 | 'None'
29 | 'Floyd-Steinberg'
30 | 'Burkes'
31 | 'Stucki'
32 | 'Jarvis'
33 | 'Atkinson'
34 | 'Sierra 2'
35 | 'Sierra 3'
36 | 'Sierra 4'
37 | )
38 | TabOrder = 0
39 | end
40 | object Button1: TButton
41 | Left = 320
42 | Height = 25
43 | Top = 24
44 | Width = 75
45 | Caption = 'OK'
46 | TabOrder = 1
47 | OnClick = Button1Click
48 | end
49 | object GroupBox1: TGroupBox
50 | Left = 16
51 | Height = 208
52 | Top = 16
53 | Width = 137
54 | Caption = 'Colors'
55 | ClientHeight = 188
56 | ClientWidth = 133
57 | TabOrder = 2
58 | object Edit1: TEdit
59 | Left = 56
60 | Height = 23
61 | Top = 152
62 | Width = 56
63 | TabOrder = 0
64 | Text = '256'
65 | end
66 | object UpDown1: TUpDown
67 | Left = 112
68 | Height = 23
69 | Top = 152
70 | Width = 17
71 | Associate = Edit1
72 | Max = 256
73 | Min = 2
74 | Position = 256
75 | TabOrder = 1
76 | end
77 | object RadioButton1: TRadioButton
78 | Tag = 2
79 | Left = 8
80 | Height = 19
81 | Top = 11
82 | Width = 24
83 | Caption = '2'
84 | TabOrder = 2
85 | end
86 | object RadioButton2: TRadioButton
87 | Tag = 16
88 | Left = 8
89 | Height = 19
90 | Top = 32
91 | Width = 30
92 | Caption = '16'
93 | TabOrder = 3
94 | end
95 | object RadioButton3: TRadioButton
96 | Tag = 32
97 | Left = 8
98 | Height = 19
99 | Top = 56
100 | Width = 30
101 | Caption = '32'
102 | TabOrder = 4
103 | end
104 | object RadioButton4: TRadioButton
105 | Tag = 64
106 | Left = 8
107 | Height = 19
108 | Top = 80
109 | Width = 30
110 | Caption = '64'
111 | TabOrder = 5
112 | end
113 | object RadioButton5: TRadioButton
114 | Tag = 128
115 | Left = 8
116 | Height = 19
117 | Top = 104
118 | Width = 36
119 | Caption = '128'
120 | TabOrder = 6
121 | end
122 | object RadioButton6: TRadioButton
123 | Tag = 256
124 | Left = 8
125 | Height = 19
126 | Top = 128
127 | Width = 36
128 | Caption = '256'
129 | Checked = True
130 | TabOrder = 7
131 | TabStop = True
132 | end
133 | object RadioButton7: TRadioButton
134 | Tag = 1
135 | Left = 8
136 | Height = 19
137 | Top = 152
138 | Width = 41
139 | Caption = '--->'
140 | TabOrder = 8
141 | end
142 | end
143 | end
144 |
--------------------------------------------------------------------------------
/dlg_colors.pas:
--------------------------------------------------------------------------------
1 | unit dlg_colors;
2 |
3 | //Lazzy Image Viewer
4 | //github.com/PascalVault
5 | //License: GNU/GPL
6 |
7 | {$mode ObjFPC}{$H+}
8 |
9 | interface
10 |
11 | uses
12 | Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
13 | ComCtrls, PV_Bitmap;
14 |
15 | type
16 |
17 | { TColorsDlg }
18 |
19 | TColorsDlg = class(TForm)
20 | Button1: TButton;
21 | Edit1: TEdit;
22 | GroupBox1: TGroupBox;
23 | RadioButton1: TRadioButton;
24 | RadioButton2: TRadioButton;
25 | RadioButton3: TRadioButton;
26 | RadioButton4: TRadioButton;
27 | RadioButton5: TRadioButton;
28 | RadioButton6: TRadioButton;
29 | RadioButton7: TRadioButton;
30 | RadioGroup1: TRadioGroup;
31 | UpDown1: TUpDown;
32 | procedure Button1Click(Sender: TObject);
33 | private
34 |
35 | public
36 | ColorMode: Integer;
37 | procedure Show(Num: Integer); overload;
38 | end;
39 |
40 | var
41 | ColorsDlg: TColorsDlg;
42 |
43 | implementation
44 |
45 | uses Unit1;
46 |
47 | {$R *.lfm}
48 |
49 | { TColorsDlg }
50 |
51 | procedure TColorsDlg.Button1Click(Sender: TObject);
52 | var i: Integer;
53 | ColorCount: Integer;
54 | Dither: TDither;
55 | begin
56 | for i:=0 to GroupBox1.ControlCount - 1 do
57 | if (GroupBox1.Controls[i] is TRadioButton) and TRadioButton(GroupBox1.Controls[i]).Checked then begin
58 | ColorCount := GroupBox1.Controls[i].Tag;
59 | break;
60 | end;
61 |
62 | if ColorCount = 1 then ColorCount := UpDown1.Position;
63 |
64 | case RadioGroup1.ItemIndex of
65 | 0 : Dither := ddNone;
66 | 1 : Dither := ddFloyd;
67 | 2 : Dither := ddBurkes;
68 | 3 : Dither := ddStucki;
69 | 4 : Dither := ddJarvis;
70 | 5 : Dither := ddAtkinson;
71 | 6 : Dither := ddSierra2;
72 | 7 : Dither := ddSierra3;
73 | 8 : Dither := ddSierra4;
74 | end;
75 |
76 | Form1.SaveUndo;
77 |
78 | if ColorMode = 256 then
79 | Form1.GetBmp.ReduceColors(ColorCount-1, Dither)
80 | else if ColorMode = -256 then
81 | Form1.GetBmp.Grayscale(ColorCount-1, Dither)
82 | else if ColorMode = 2 then
83 | Form1.GetBmp.BlackWhite(Dither);
84 |
85 | Form1.Redraw;
86 |
87 | Close;
88 | end;
89 |
90 | procedure TColorsDlg.Show(Num: Integer);
91 | begin
92 | ColorMode := Num;
93 |
94 | if Num = 2 then begin
95 | RadioButton1.Checked := True;
96 | end
97 | else RadioButton5.Checked := True;
98 |
99 | Show;
100 | end;
101 |
102 | end.
103 |
104 |
--------------------------------------------------------------------------------
/dlg_formats.lfm:
--------------------------------------------------------------------------------
1 | object FormatsDlg: TFormatsDlg
2 | Left = 601
3 | Height = 290
4 | Top = 359
5 | Width = 418
6 | Caption = 'Supported formats'
7 | ClientHeight = 290
8 | ClientWidth = 418
9 | OnCreate = FormCreate
10 | LCLVersion = '3.0.0.3'
11 | object SG: TStringGrid
12 | Left = 0
13 | Height = 256
14 | Top = 0
15 | Width = 418
16 | Align = alClient
17 | ColCount = 3
18 | TabOrder = 0
19 | end
20 | object Panel1: TPanel
21 | Left = 0
22 | Height = 34
23 | Top = 256
24 | Width = 418
25 | Align = alBottom
26 | Caption = 'Panel1'
27 | TabOrder = 1
28 | end
29 | end
30 |
--------------------------------------------------------------------------------
/dlg_formats.pas:
--------------------------------------------------------------------------------
1 | unit dlg_formats;
2 |
3 | {$mode ObjFPC}{$H+}
4 |
5 | interface
6 |
7 | uses
8 | Classes, SysUtils, Forms, Controls, Graphics, Dialogs, Grids, ExtCtrls,
9 | PV_Bitmap, PV_BitmapFormats;
10 |
11 | type
12 |
13 | { TFormatsDlg }
14 |
15 | TFormatsDlg = class(TForm)
16 | Panel1: TPanel;
17 | SG: TStringGrid;
18 | procedure FormCreate(Sender: TObject);
19 | private
20 |
21 | public
22 |
23 | end;
24 |
25 | var
26 | FormatsDlg: TFormatsDlg;
27 |
28 | implementation
29 |
30 | uses Unit1;
31 |
32 | {$R *.lfm}
33 |
34 | { TFormatsDlg }
35 |
36 | function ListSort(List: TStringList; Index1, Index2: Integer): Integer;
37 | begin
38 | Result := CompareStr( List[Index1] , List[Index2] );
39 | end;
40 |
41 | procedure TFormatsDlg.FormCreate(Sender: TObject);
42 | var i: Integer;
43 | Ext, AName: String;
44 | R: TPV_BitmapReader;
45 | W: TPV_BitmapWriter;
46 | Reader,Writer: String;
47 | SumR,SumW: Integer;
48 | Temp: TStringList;
49 | begin
50 | SG.ColWidths[0] := 250;
51 | SG.Rows[0].CommaText := 'Format,Read,Write';
52 |
53 | SG.RowCount := BitmapFormats.Count+1;
54 | SumR := 0;
55 | SumW := 0;
56 |
57 | Temp := TStringList.Create;
58 |
59 | for i:=0 to BitmapFormats.Count-1 do begin
60 | BitmapFormats.Item(i, Ext, AName, R, W);
61 |
62 | if R = nil then Reader := ''
63 | else Reader := '+';
64 |
65 | if W = nil then Writer := ''
66 | else Writer := '+';
67 |
68 | if R <> nil then Inc(SumR);
69 | if W <> nil then Inc(SumW);
70 |
71 | Temp.Add( '"' + AName + ' (.' + Ext + ')",' + Reader + ',' + Writer );
72 | end;
73 |
74 | Temp.CustomSort(@ListSort);
75 |
76 | for i:=0 to Temp.Count-1 do
77 | SG.Rows[i+1].CommaText := Temp[i];
78 |
79 | Temp.Free;
80 |
81 | Panel1.Caption := 'Read: ' + IntToStr(SumR) + ', Write: ' + IntToStr(SumW);
82 | end;
83 |
84 | end.
85 |
86 |
--------------------------------------------------------------------------------
/dlg_info.lfm:
--------------------------------------------------------------------------------
1 | object InfoDlg: TInfoDlg
2 | Left = 655
3 | Height = 187
4 | Top = 467
5 | Width = 300
6 | Caption = 'Info'
7 | ClientHeight = 187
8 | ClientWidth = 300
9 | LCLVersion = '3.0.0.3'
10 | object Label1: TLabel
11 | Left = 18
12 | Height = 15
13 | Top = 14
14 | Width = 38
15 | Caption = 'Format'
16 | end
17 | object Edit1: TEdit
18 | Left = 98
19 | Height = 23
20 | Top = 14
21 | Width = 195
22 | ReadOnly = True
23 | TabOrder = 0
24 | end
25 | object Label2: TLabel
26 | Left = 16
27 | Height = 15
28 | Top = 48
29 | Width = 32
30 | Caption = 'Width'
31 | end
32 | object Edit2: TEdit
33 | Left = 96
34 | Height = 23
35 | Top = 48
36 | Width = 104
37 | ReadOnly = True
38 | TabOrder = 1
39 | end
40 | object Label3: TLabel
41 | Left = 16
42 | Height = 15
43 | Top = 80
44 | Width = 36
45 | Caption = 'Height'
46 | end
47 | object Edit3: TEdit
48 | Left = 96
49 | Height = 23
50 | Top = 80
51 | Width = 104
52 | ReadOnly = True
53 | TabOrder = 2
54 | end
55 | object Label4: TLabel
56 | Left = 16
57 | Height = 15
58 | Top = 112
59 | Width = 37
60 | Caption = 'Filesize'
61 | end
62 | object Edit4: TEdit
63 | Left = 96
64 | Height = 23
65 | Top = 112
66 | Width = 104
67 | ReadOnly = True
68 | TabOrder = 3
69 | end
70 | object Label5: TLabel
71 | Left = 18
72 | Height = 15
73 | Top = 144
74 | Width = 67
75 | Caption = 'Bits per pixel'
76 | end
77 | object Edit5: TEdit
78 | Left = 96
79 | Height = 23
80 | Top = 144
81 | Width = 104
82 | ReadOnly = True
83 | TabOrder = 4
84 | end
85 | object Button1: TButton
86 | Left = 216
87 | Height = 25
88 | Top = 144
89 | Width = 75
90 | Caption = 'OK'
91 | TabOrder = 5
92 | end
93 | end
94 |
--------------------------------------------------------------------------------
/dlg_info.pas:
--------------------------------------------------------------------------------
1 | unit dlg_info;
2 |
3 | {$mode ObjFPC}{$H+}
4 |
5 | interface
6 |
7 | uses
8 | Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
9 |
10 | type
11 |
12 | { TInfoDlg }
13 |
14 | TInfoDlg = class(TForm)
15 | Button1: TButton;
16 | Edit1: TEdit;
17 | Edit2: TEdit;
18 | Edit3: TEdit;
19 | Edit4: TEdit;
20 | Edit5: TEdit;
21 | Label1: TLabel;
22 | Label2: TLabel;
23 | Label3: TLabel;
24 | Label4: TLabel;
25 | Label5: TLabel;
26 | private
27 |
28 | public
29 |
30 | end;
31 |
32 | var
33 | InfoDlg: TInfoDlg;
34 |
35 | implementation
36 |
37 | {$R *.lfm}
38 |
39 | end.
40 |
41 |
--------------------------------------------------------------------------------
/dlg_params.lfm:
--------------------------------------------------------------------------------
1 | object ParamsDlg: TParamsDlg
2 | Left = 622
3 | Height = 115
4 | Top = 214
5 | Width = 289
6 | Caption = 'Filter'
7 | ClientHeight = 115
8 | ClientWidth = 289
9 | LCLVersion = '3.0.0.3'
10 | object ScrollBar1: TScrollBar
11 | Left = 16
12 | Height = 17
13 | Top = 24
14 | Width = 200
15 | Min = -100
16 | PageSize = 0
17 | TabOrder = 0
18 | OnChange = ScrollBar1Change
19 | end
20 | object Label1: TLabel
21 | Left = 233
22 | Height = 15
23 | Top = 26
24 | Width = 6
25 | Caption = '0'
26 | end
27 | object Button1: TButton
28 | Left = 200
29 | Height = 25
30 | Top = 72
31 | Width = 75
32 | Caption = 'OK'
33 | TabOrder = 1
34 | OnClick = Button1Click
35 | end
36 | end
37 |
--------------------------------------------------------------------------------
/dlg_params.pas:
--------------------------------------------------------------------------------
1 | unit dlg_params;
2 |
3 | //Lazzy Image Viewer
4 | //github.com/PascalVault
5 | //License: GNU/GPL
6 |
7 | {$mode ObjFPC}{$H+}
8 |
9 | interface
10 |
11 | uses
12 | Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
13 |
14 | type
15 |
16 | { TParamsDlg }
17 |
18 | TParamsDlg = class(TForm)
19 | Button1: TButton;
20 | Label1: TLabel;
21 | ScrollBar1: TScrollBar;
22 | procedure Button1Click(Sender: TObject);
23 | procedure ScrollBar1Change(Sender: TObject);
24 | private
25 |
26 | public
27 | TheMin, TheMax, TheVal: Integer;
28 | procedure Setup;
29 | end;
30 |
31 | var
32 | ParamsDlg: TParamsDlg;
33 |
34 | implementation
35 |
36 | {$R *.lfm}
37 |
38 | { TParamsDlg }
39 |
40 | procedure TParamsDlg.ScrollBar1Change(Sender: TObject);
41 | begin
42 | TheVal := ScrollBar1.Position;
43 |
44 | Label1.Caption := IntToStr(TheVal);
45 | end;
46 |
47 | procedure TParamsDlg.Setup;
48 | begin
49 | ScrollBar1.Max := TheMax;
50 | ScrollBar1.Min := TheMin;
51 |
52 | ScrollBar1.Position := TheVal;
53 | Label1.Caption := IntToStr(TheVal);
54 | end;
55 |
56 | procedure TParamsDlg.Button1Click(Sender: TObject);
57 | begin
58 | Close;
59 | end;
60 |
61 | end.
62 |
63 |
--------------------------------------------------------------------------------
/dlg_resize.lfm:
--------------------------------------------------------------------------------
1 | object ResizeDlg: TResizeDlg
2 | Left = 396
3 | Height = 242
4 | Top = 205
5 | Width = 470
6 | Caption = 'Resize'
7 | ClientHeight = 242
8 | ClientWidth = 470
9 | LCLVersion = '3.0.0.3'
10 | object Button1: TButton
11 | Left = 373
12 | Height = 25
13 | Top = 32
14 | Width = 75
15 | Caption = 'OK'
16 | TabOrder = 0
17 | OnClick = Button1Click
18 | end
19 | object GroupBox1: TGroupBox
20 | Left = 120
21 | Height = 97
22 | Top = 16
23 | Width = 237
24 | ClientHeight = 77
25 | ClientWidth = 233
26 | TabOrder = 1
27 | object Label5: TLabel
28 | Left = 16
29 | Height = 15
30 | Top = 8
31 | Width = 32
32 | Caption = 'Width'
33 | end
34 | object Label6: TLabel
35 | Left = 16
36 | Height = 15
37 | Top = 40
38 | Width = 36
39 | Caption = 'Height'
40 | end
41 | object Edit3: TEdit
42 | Left = 71
43 | Height = 23
44 | Top = 8
45 | Width = 80
46 | TabOrder = 0
47 | Text = '200'
48 | end
49 | object Edit4: TEdit
50 | Left = 71
51 | Height = 23
52 | Top = 40
53 | Width = 80
54 | TabOrder = 1
55 | Text = '200'
56 | end
57 | object UpDown3: TUpDown
58 | Left = 151
59 | Height = 23
60 | Top = 8
61 | Width = 17
62 | Associate = Edit3
63 | Max = 16000
64 | Min = 0
65 | Position = 200
66 | TabOrder = 2
67 | end
68 | object UpDown4: TUpDown
69 | Left = 151
70 | Height = 23
71 | Top = 40
72 | Width = 17
73 | Associate = Edit4
74 | Max = 16000
75 | Min = 0
76 | Position = 200
77 | TabOrder = 3
78 | end
79 | object Label7: TLabel
80 | Left = 176
81 | Height = 15
82 | Top = 8
83 | Width = 13
84 | Caption = 'px'
85 | end
86 | object Label8: TLabel
87 | Left = 176
88 | Height = 15
89 | Top = 40
90 | Width = 13
91 | Caption = 'px'
92 | end
93 | end
94 | object GroupBox2: TGroupBox
95 | Left = 120
96 | Height = 97
97 | Top = 128
98 | Width = 237
99 | ClientHeight = 77
100 | ClientWidth = 233
101 | TabOrder = 2
102 | object Label9: TLabel
103 | Left = 16
104 | Height = 15
105 | Top = 8
106 | Width = 32
107 | Caption = 'Width'
108 | end
109 | object Label10: TLabel
110 | Left = 16
111 | Height = 15
112 | Top = 40
113 | Width = 36
114 | Caption = 'Height'
115 | end
116 | object Edit5: TEdit
117 | Left = 71
118 | Height = 23
119 | Top = 8
120 | Width = 80
121 | TabOrder = 0
122 | Text = '100'
123 | end
124 | object Edit6: TEdit
125 | Left = 71
126 | Height = 23
127 | Top = 40
128 | Width = 80
129 | TabOrder = 1
130 | Text = '100'
131 | end
132 | object UpDown5: TUpDown
133 | Left = 151
134 | Height = 23
135 | Top = 8
136 | Width = 17
137 | Associate = Edit5
138 | Max = 800
139 | Min = 0
140 | Position = 100
141 | TabOrder = 2
142 | end
143 | object UpDown6: TUpDown
144 | Left = 151
145 | Height = 23
146 | Top = 40
147 | Width = 17
148 | Associate = Edit6
149 | Max = 800
150 | Min = 0
151 | Position = 100
152 | TabOrder = 3
153 | end
154 | object Label11: TLabel
155 | Left = 176
156 | Height = 15
157 | Top = 8
158 | Width = 10
159 | Caption = '%'
160 | end
161 | object Label12: TLabel
162 | Left = 176
163 | Height = 15
164 | Top = 40
165 | Width = 10
166 | Caption = '%'
167 | end
168 | end
169 | object Button2: TButton
170 | Left = 373
171 | Height = 25
172 | Top = 144
173 | Width = 75
174 | Caption = 'OK'
175 | TabOrder = 3
176 | OnClick = Button2Click
177 | end
178 | object RG: TRadioGroup
179 | Left = 24
180 | Height = 209
181 | Top = 16
182 | Width = 88
183 | AutoFill = True
184 | Caption = 'Method'
185 | ChildSizing.LeftRightSpacing = 6
186 | ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
187 | ChildSizing.EnlargeVertical = crsHomogenousChildResize
188 | ChildSizing.ShrinkHorizontal = crsScaleChilds
189 | ChildSizing.ShrinkVertical = crsScaleChilds
190 | ChildSizing.Layout = cclLeftToRightThenTopToBottom
191 | ChildSizing.ControlsPerLine = 1
192 | ClientHeight = 189
193 | ClientWidth = 84
194 | ItemIndex = 3
195 | Items.Strings = (
196 | 'System'
197 | 'Bell'
198 | 'Hermite'
199 | 'Lanczos'
200 | 'Mitchel'
201 | 'Spline'
202 | )
203 | TabOrder = 4
204 | end
205 | end
206 |
--------------------------------------------------------------------------------
/dlg_resize.pas:
--------------------------------------------------------------------------------
1 | unit dlg_resize;
2 |
3 | //Lazzy Image Viewer
4 | //github.com/PascalVault
5 | //License: GNU/GPL
6 |
7 | {$mode ObjFPC}{$H+}
8 |
9 | interface
10 |
11 | uses
12 | Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls,
13 | ExtCtrls, PV_Filters;
14 |
15 | type
16 |
17 | { TResizeDlg }
18 |
19 | TResizeDlg = class(TForm)
20 | Button1: TButton;
21 | Button2: TButton;
22 | Edit3: TEdit;
23 | Edit4: TEdit;
24 | Edit5: TEdit;
25 | Edit6: TEdit;
26 | GroupBox1: TGroupBox;
27 | GroupBox2: TGroupBox;
28 | Label10: TLabel;
29 | Label11: TLabel;
30 | Label12: TLabel;
31 | Label5: TLabel;
32 | Label6: TLabel;
33 | Label7: TLabel;
34 | Label8: TLabel;
35 | Label9: TLabel;
36 | RG: TRadioGroup;
37 | UpDown3: TUpDown;
38 | UpDown4: TUpDown;
39 | UpDown5: TUpDown;
40 | UpDown6: TUpDown;
41 | procedure Button1Click(Sender: TObject);
42 | procedure Button2Click(Sender: TObject);
43 | private
44 |
45 | public
46 |
47 | end;
48 |
49 | var
50 | ResizeDlg: TResizeDlg;
51 |
52 | implementation
53 |
54 | uses Unit1;
55 |
56 | {$R *.lfm}
57 |
58 | { TResizeDlg }
59 |
60 | procedure TResizeDlg.Button1Click(Sender: TObject);
61 | begin
62 | Form1.SaveUndo;
63 |
64 | case RG.ItemIndex of
65 | 0: Form1.GetBmp.Resize(UpDown3.Position, UpDown4.Position);
66 | 1: Form1.GetBmp.Resample(UpDown3.Position, UpDown4.Position, rfBox);
67 | 2: Form1.GetBmp.Resample(UpDown3.Position, UpDown4.Position, rfBilinear);
68 | 3: Form1.GetBmp.Resample(UpDown3.Position, UpDown4.Position, rfBell);
69 | 4: Form1.GetBmp.Resample(UpDown3.Position, UpDown4.Position, rfHermite);
70 | 5: Form1.GetBmp.Resample(UpDown3.Position, UpDown4.Position, rfLanczos3);
71 | 6: Form1.GetBmp.Resample(UpDown3.Position, UpDown4.Position, rfMitchell);
72 | 7: Form1.GetBmp.Resample(UpDown3.Position, UpDown4.Position, rfSpline);
73 | end;
74 |
75 | Form1.Redraw;
76 | Close;
77 | end;
78 |
79 | procedure TResizeDlg.Button2Click(Sender: TObject);
80 | begin
81 | Form1.SaveUndo;
82 |
83 | case RG.ItemIndex of
84 | 0: Form1.GetBmp.ResizePercent(UpDown5.Position, UpDown6.Position);
85 | 1: Form1.GetBmp.ResamplePercent(UpDown5.Position, UpDown6.Position, rfBox);
86 | 2: Form1.GetBmp.ResamplePercent(UpDown5.Position, UpDown6.Position, rfBilinear);
87 | 3: Form1.GetBmp.ResamplePercent(UpDown5.Position, UpDown6.Position, rfBell);
88 | 4: Form1.GetBmp.ResamplePercent(UpDown5.Position, UpDown6.Position, rfHermite);
89 | 5: Form1.GetBmp.ResamplePercent(UpDown5.Position, UpDown6.Position, rfLanczos3);
90 | 6: Form1.GetBmp.ResamplePercent(UpDown5.Position, UpDown6.Position, rfMitchell);
91 | 7: Form1.GetBmp.ResamplePercent(UpDown5.Position, UpDown6.Position, rfSpline);
92 | end;
93 |
94 | Form1.Redraw;
95 | Close;
96 | end;
97 |
98 | end.
99 |
100 |
--------------------------------------------------------------------------------
/fpwritegif.pas:
--------------------------------------------------------------------------------
1 | unit FPWriteGIF;
2 |
3 | //Copyright (c) 2007-2024, Udo Schmal
4 | //License: MIT
5 |
6 | {$mode objfpc}{$H+}
7 | interface
8 |
9 | uses Classes, SysUtils, FPImage, FPReadGif;
10 |
11 | type TColor = -$7FFFFFFF - 1..$7FFFFFFF;
12 |
13 | const
14 | // GIF record separators
15 | kGifImageSeparator: byte = $2c;
16 | kGifExtensionSeparator: byte = $21;
17 | kGifTerminator: byte = $3b;
18 | kGifLabelGraphic: byte = $f9;
19 | kGifBlockTerminator: byte = $00;
20 | // LZW encode table sizes
21 | kGifCodeTableSize = 4096;
22 | // Raw rgb value
23 | clNone = TColor($1FFFFFFF);
24 | AlphaOpaque = $FF;
25 | AlphaTransparent = 0;
26 | MaxArr = (MaxLongint div Sizeof(integer)) - 1;
27 |
28 | type
29 | APixel8 = array[0..MaxArr] of Byte;
30 | PAPixel8 = ^APixel8;
31 |
32 | TRGBQuadArray256 = array[0..256] of TFPCompactImgRGBA8BitValue;
33 | TOpenColorTableArray = array of TColor;
34 | TColorTableArray = array[0..$FF] of TColor;
35 |
36 | TOctreeNode = class; // Forward definition so TReducibleNodes can be declared
37 | TReducibleNodes = array[0..7] of TOctreeNode;
38 | TOctreeNode = class(TObject)
39 | IsLeaf: Boolean;
40 | PixelCount: Integer;
41 | RedSum, GreenSum, BlueSum: Integer;
42 | Next: TOctreeNode;
43 | Child: TReducibleNodes;
44 | constructor Create(const Level: Integer; var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
45 | destructor Destroy; override;
46 | end;
47 |
48 | TFPWriterGIF = class(TFPCustomImageWriter)
49 | private
50 | fHeader: TGifHeader;
51 | fDescriptor: TGifImageDescriptor; // only one image supported
52 | fGraphicsCtrlExt: TGifGraphicsControlExtension;
53 | fTransparent: Boolean;
54 | fBackground: TColor;
55 | fPixels: PAPixel8;
56 | fPixelList: PChar; // decoded pixel indices
57 | fPixelCount: longint; // number of pixels
58 | fColorTable: TColorTableArray;
59 | fColorTableSize: integer;
60 |
61 | procedure SaveToStream(Destination: TStream);
62 | protected
63 | procedure InternalWrite(Stream: TStream; Img: TFPCustomImage); override;
64 | public
65 | constructor Create; override;
66 | destructor Destroy; override;
67 | end;
68 |
69 | implementation
70 | {$REGION ' - TOctreeNode - '}
71 | constructor TOctreeNode.Create(const Level: Integer; var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
72 | var i: Integer;
73 | begin
74 | PixelCount := 0;
75 | RedSum := 0;
76 | GreenSum := 0;
77 | BlueSum := 0;
78 | for i := Low(Child) to High(Child) do
79 | Child[i] := nil;
80 | IsLeaf := (Level = 8);
81 | if IsLeaf then
82 | begin
83 | Next := nil;
84 | Inc(LeafCount);
85 | end
86 | else
87 | begin
88 | Next := ReducibleNodes[Level];
89 | ReducibleNodes[Level] := Self;
90 | end
91 | end;
92 |
93 | destructor TOctreeNode.Destroy;
94 | var i: Integer;
95 | begin
96 | for i := Low(Child) to High(Child) do
97 | Child[i].Free
98 | end;
99 | {$ENDREGION}
100 |
101 | {$REGION ' - TFPWriterGIF. - '}
102 | constructor TFPWriterGIF.Create;
103 | begin
104 | inherited Create;
105 | end;
106 |
107 | destructor TFPWriterGIF.Destroy;
108 | begin
109 | inherited Destroy;
110 | end;
111 |
112 | // save the current GIF definition to a stream object
113 | // at first, just write it to our memory stream fSOURCE
114 | procedure TFPWriterGIF.SaveToStream(Destination: TStream);
115 | var
116 | LZWStream: TMemoryStream; // temp storage for LZW
117 | LZWSize: integer; // LZW minimum code size
118 |
119 | // these LZW encode routines sqrunch a bitmap into a memory stream
120 | procedure LZWEncode();
121 | var
122 | rPrefix: array[0..kGifCodeTableSize-1] of integer; // string prefixes
123 | rSuffix: array[0..kGifCodeTableSize-1] of integer; // string suffixes
124 | rCodeStack: array[0..kGifCodeTableSize-1] of byte; // encoded pixels
125 | rSP: integer; // pointer into CodeStack
126 | rClearCode: integer; // reset decode params
127 | rEndCode: integer; // last code in input stream
128 | rCurSize: integer; // current code size
129 | rBitString: integer; // steady stream of bits to be decoded
130 | rBits: integer; // number of valid bits in BitString
131 | rMaxVal: boolean; // max code value found?
132 | rCurX: integer; // position of next pixel
133 | rCurY: integer; // position of next pixel
134 | rCurPass: integer; // pixel line pass 1..4
135 | rFirstSlot: integer; // for encoding an image
136 | rNextSlot: integer; // for encoding
137 | rCount: integer; // number of bytes read/written
138 | rLast: integer; // last byte read in
139 | rUnget: boolean; // read a new byte, or use zLast?
140 |
141 | procedure LZWReset;
142 | var i: integer;
143 | begin
144 | for i := 0 to (kGifCodeTableSize - 1) do
145 | begin
146 | rPrefix[i] := 0;
147 | rSuffix[i] := 0;
148 | end;
149 | rCurSize := LZWSize + 1;
150 | rClearCode := (1 shl LZWSize);
151 | rEndCode := rClearCode + 1;
152 | rFirstSlot := (1 shl (rCurSize - 1)) + 2;
153 | rNextSlot := rFirstSlot;
154 | rMaxVal := false;
155 | end;
156 |
157 | // save a code value on the code stack
158 | procedure LZWSaveCode(Code: integer);
159 | begin
160 | rCodeStack[rSP] := Code;
161 | inc(rSP);
162 | end;
163 |
164 | // save the code in the output data stream
165 | procedure LZWPutCode(code: integer);
166 | var
167 | n: integer;
168 | b: byte;
169 | begin
170 | // write out finished bytes
171 | // a literal "8" for 8 bits per byte
172 | while (rBits >= 8) do
173 | begin
174 | b := (rBitString and $ff);
175 | rBitString := (rBitString shr 8);
176 | rBits := rBits - 8;
177 | LZWStream.Write(b, 1);
178 | end;
179 | // make sure no junk bits left above the first byte
180 | rBitString := (rBitString and $ff);
181 | // and save out-going code
182 | n := (code shl rBits);
183 | rBitString := (rBitString or n);
184 | rBits := rBits + rCurSize;
185 | end;
186 |
187 | // get the next pixel from the bitmap, and return it as an index into the colormap
188 | function LZWReadBitmap: integer;
189 | var
190 | n: integer;
191 | j: longint;
192 | p: PChar;
193 | begin
194 | if (rUnget) then
195 | begin
196 | n := rLast;
197 | rUnget := false;
198 | end
199 | else
200 | begin
201 | inc(rCount);
202 | j := (rCurY * fDescriptor.Width) + rCurX;
203 | if ((0 <= j) and (j < fPixelCount)) then
204 | begin
205 | p := fPixelList + j;
206 | n := ord(p^);
207 | end
208 | else
209 | n := 0;
210 | // if first pass, make sure CurPass was initialized
211 | if (rCurPass = 0) then rCurPass := 1;
212 | inc(rCurX); // inc X position
213 | if (rCurX >= fDescriptor.Width) then // bumping Y ?
214 | begin
215 | rCurX := 0;
216 | inc(rCurY);
217 | end;
218 | end;
219 | rLast := n;
220 | result := n;
221 | end;
222 |
223 | var
224 | i,n,
225 | cc: integer; // current code to translate
226 | oc: integer; // last code encoded
227 | found: boolean; // decoded string in prefix table?
228 | pixel: byte; // lowest code to search for
229 | ldx: integer; // last index found
230 | fdx: integer; // current index found
231 | b: byte;
232 | begin
233 | // init data block
234 | fillchar(rCodeStack, sizeof(rCodeStack), 0);
235 | rBitString := 0;
236 | rBits := 0;
237 | rCurX := 0;
238 | rCurY := 0;
239 | rCurPass := 0;
240 | rLast := 0;
241 | rUnget:= false;
242 |
243 | LZWReset;
244 | // all within the data record
245 | // always save the clear code first ...
246 | LZWPutCode(rClearCode);
247 | // and first pixel
248 | oc := LZWReadBitmap;
249 | LZWPutCode(oc);
250 | // nothing found yet (but then, we haven't searched)
251 | ldx := 0;
252 | fdx := 0;
253 | // and the rest of the pixels
254 | rCount := 1;
255 | while (rCount <= fPixelCount) do
256 | begin
257 | rSP := 0; // empty the stack of old data
258 | n := LZWReadBitmap; // next pixel from the bitmap
259 | LZWSaveCode(n);
260 | cc := rCodeStack[0]; // beginning of the string
261 | // add new encode table entry
262 | rPrefix[rNextSlot] := oc;
263 | rSuffix[rNextSlot] := cc;
264 | inc(rNextSlot);
265 | if (rNextSlot >= kGifCodeTableSize) then
266 | rMaxVal := true
267 | else if (rNextSlot > (1 shl rCurSize)) then
268 | inc(rCurSize);
269 | // find the running string of matching codes
270 | ldx := cc;
271 | found := true;
272 | while (found and (rCount <= fPixelCount)) do
273 | begin
274 | n := LZWReadBitmap;
275 | LZWSaveCode(n);
276 | cc := rCodeStack[0];
277 | if (ldx < rFirstSlot) then
278 | i := rFirstSlot
279 | else
280 | i := ldx + 1;
281 | pixel := rCodeStack[rSP - 1];
282 | found := false;
283 | while ((not found) and (i < rNextSlot)) do
284 | begin
285 | found := ((rPrefix[i] = ldx) and (rSuffix[i] = pixel));
286 | inc(i);
287 | end;
288 | if (found) then
289 | begin
290 | ldx := i - 1;
291 | fdx := i - 1;
292 | end;
293 | end;
294 | // if not found, save this index, and get the same code again
295 | if (not found) then
296 | begin
297 | rUnget := true;
298 | rLast := rCodeStack[rSP-1];
299 | dec(rSP);
300 | cc := ldx;
301 | end
302 | else
303 | cc := fdx;
304 | // whatever we got, write it out as current table entry
305 | LZWPutCode(cc);
306 | if ((rMaxVal) and (rCount <= fPixelCount)) then
307 | begin
308 | LZWPutCode(rClearCode);
309 | LZWReset;
310 | cc := LZWReadBitmap;
311 | LZWPutCode(cc);
312 | end;
313 | oc := cc;
314 | end;
315 | LZWPutCode(rEndCode);
316 | // write out the rest of the bit string
317 | while (rBits > 0) do
318 | begin
319 | b := (rBitString and $ff);
320 | rBitString := (rBitString shr 8);
321 | rBits := rBits - 8;
322 | LZWStream.Write(b, 1);
323 | end;
324 | end;
325 |
326 | var i: integer;
327 | begin
328 | Destination.Position := 0;
329 | with fHeader do
330 | begin
331 | // write the GIF signature
332 | // if only one image, and no image extensions, then GIF is GIF87a,
333 | // else use the updated version GIF98a
334 | // we just added an extension block; the signature must be version 89a
335 | Destination.Write(Signature, 3);
336 | Destination.Write(Version, 3);
337 | // write the overall GIF screen description to the source stream
338 | Destination.Write(ScreenWidth, 2); // logical screen width
339 | Destination.Write(ScreenHeight, 2); // logical screen height
340 | Destination.Write(Packedbit, 1); // packed bit fields (Global Color valid, Global Color size, Sorted, Color Resolution)
341 | Destination.Write(BackgroundColor, 1); // background color
342 | Destination.Write(AspectRatio, 1); // pixel aspect ratio
343 | if (Packedbit and $80)>0 then //Global Color valid
344 | // write out color gobal table with RGB values
345 | for i := 0 to fColorTableSize-1 do
346 | Destination.Write(fColorTable[i], 3);
347 | end;
348 | // write out graphic extension for this image
349 | Destination.Write(kGifExtensionSeparator, 1); // write the extension separator
350 | Destination.Write(kGifLabelGraphic, 1); // write the extension label
351 | Destination.Write(fGraphicsCtrlExt.BlockSize, 1); // block size (always 4)
352 | Destination.Write(fGraphicsCtrlExt.Packedbit, 1); // packed bit field
353 | Destination.Write(fGraphicsCtrlExt.DelayTime, 2); // delay time
354 | Destination.Write(fGraphicsCtrlExt.ColorIndex, 1); // transparent color
355 | Destination.Write(fGraphicsCtrlExt.Terminator, 1); // block terminator
356 | // write actual image data
357 | Destination.Write(kGifImageSeparator, 1);
358 | // write the next image descriptor shortcut to the record fields
359 | with fDescriptor do
360 | begin
361 | // write the basic descriptor record
362 | Destination.Write(Left, 2); // left position
363 | Destination.Write(Top, 2); // top position
364 | Destination.Write(Width, 2); // size of image
365 | Destination.Write(Height, 2); // size of image
366 | Destination.Write(Packedbit, 1); // packed bit field
367 | // there is no local color table defined we use global
368 | LZWSize := 8; // the LZW minimum code size
369 | Destination.Write(LZWSize, 1);
370 | LZWStream := TMemoryStream.Create; // init the storage for compressed data
371 | try
372 | LZWEncode(); // encode the image and save it in LZWStream
373 | // write out the data stream as a series of data blocks
374 | LZWStream.Position := 0;
375 | while (LZWStream.Position < LZWStream.Size) do
376 | begin
377 | i := LZWStream.Size - LZWStream.Position;
378 | if (i > 255) then i := 255;
379 | Destination.Write(i, 1);
380 | Destination.CopyFrom(LZWStream, i);
381 | end;
382 | finally
383 | FreeAndNil(LZWStream);
384 | end;
385 | Destination.Write(kGifBlockTerminator, 1); // block terminator
386 | end;
387 | Destination.Write(kGifTerminator, 1); // done with writing
388 | end;
389 |
390 | procedure TFPWriterGIF.InternalWrite(Stream: TStream; Img: TFPCustomImage);
391 | var
392 | CT: TOpenColorTableArray;
393 | Palette: TList;
394 | PaletteHasAllColours: Boolean;
395 | Mappings: array[BYTE, BYTE] of TList;
396 | Tree: TOctreeNode;
397 | LeafCount: Integer;
398 | ReducibleNodes: TReducibleNodes;
399 | LastColor: TColor;
400 | LastColorIndex: Byte;
401 |
402 | // convert TFPCustomImage TFPColor to TColor
403 | function FPColorToTColor(const FPColor: TFPColor): TColor;
404 | begin
405 | result := TColor(((FPColor.Red shr 8) and $ff) or (FPColor.Green and $ff00) or ((FPColor.Blue shl 8) and $ff0000));
406 | end;
407 |
408 | // try to make color table of all colors
409 | function MakeColorTableOfAllColors(): Boolean;
410 | var
411 | Flags: array[Byte, Byte] of TBits;
412 | x, y, ci: Cardinal;
413 | Red, Green, Blue: Byte;
414 | Cnt: word;
415 | begin
416 | result := false;
417 | // init Flags
418 | for y := 0 to $FF do
419 | for x := 0 to $FF do
420 | Flags[x, y] := nil;
421 | try
422 | for ci := 0 to $ff do
423 | CT[ci] := 0;
424 | Cnt := 0;
425 | for y := 0 to Img.Height - 1 do
426 | for x := 0 to Img.Width - 1 do
427 | begin
428 | Red := Byte(Img.Colors[x, y].red shr 8);
429 | Green := Byte(Img.Colors[x, y].green shr 8);
430 | Blue := Byte(Img.Colors[x, y].blue shr 8);
431 | if (Flags[Red, Green]) = nil then
432 | begin
433 | Flags[Red, Green] := Classes.TBits.Create;
434 | Flags[Red, Green].Size := 256;
435 | end;
436 | if not Flags[Red, Green].Bits[Blue] then
437 | begin
438 | CT[Cnt] := FPColorToTColor(Img.Colors[x, y]);
439 | if Cnt = $ff then exit;
440 | inc(Cnt);
441 | Flags[Red, Green].Bits[Blue] := true;
442 | end;
443 | end;
444 | result := true;
445 | PaletteHasAllColours := true;
446 | finally // free Flags
447 | for y := 0 to $FF do
448 | for x := 0 to $FF do
449 | if Flags[x, y] <> nil then
450 | FreeAndNil(Flags[x, y]);
451 | end;
452 | fColorTableSize := High(CT) + 1;
453 | for x := 0 to fColorTableSize - 1 do
454 | fColorTable[x] := CT[x];
455 | LastColor := clNone;
456 | end;
457 |
458 | procedure MakeColorTableofReducedColors();
459 | procedure AddColor(var Node: TOctreeNode; const r, g, b: Byte; const Level: Integer; var ReducibleNodes: TReducibleNodes);
460 | const mask: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
461 | var Index, Shift: Integer;
462 | begin
463 | if Node = nil then
464 | Node := TOctreeNode.Create(Level, LeafCount, ReducibleNodes);
465 | if Node.IsLeaf then
466 | begin
467 | Inc(Node.PixelCount);
468 | Inc(Node.RedSum, r);
469 | Inc(Node.GreenSum, g);
470 | Inc(Node.BlueSum, b)
471 | end
472 | else
473 | begin
474 | Shift := 7 - Level;
475 | Index := (((r and mask[Level]) shr Shift) shl 2) or (((g and mask[Level]) shr Shift) shl 1) or
476 | ((b and mask[Level]) shr Shift);
477 | AddColor(Node.Child[Index], r, g, b, Level + 1, ReducibleNodes)
478 | end
479 | end;
480 |
481 | procedure ReduceTree(var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
482 | var
483 | RedSum, BlueSum, GreenSum, Children, i: Integer;
484 | Node: TOctreeNode;
485 | begin
486 | i := 7;
487 | while (i > 0) and (ReducibleNodes[i] = nil) do
488 | dec(i);
489 | Node := ReducibleNodes[i];
490 | ReducibleNodes[i] := Node.Next;
491 | RedSum := 0;
492 | GreenSum := 0;
493 | BlueSum := 0;
494 | Children := 0;
495 | for i := Low(ReducibleNodes) to High(ReducibleNodes) do
496 | if Node.Child[i] <> nil then
497 | begin
498 | Inc(RedSum, Node.Child[i].RedSum);
499 | Inc(GreenSum, Node.Child[i].GreenSum);
500 | Inc(BlueSum, Node.Child[i].BlueSum);
501 | Inc(Node.PixelCount, Node.Child[i].PixelCount);
502 | Node.Child[i].Free;
503 | Node.Child[i] := nil;
504 | inc(Children)
505 | end;
506 | Node.IsLeaf := true;
507 | Node.RedSum := RedSum;
508 | Node.GreenSum := GreenSum;
509 | Node.BlueSum := BlueSum;
510 | Dec(LeafCount, Children - 1)
511 | end;
512 |
513 | procedure GetPaletteColors(const Node: TOctreeNode; var RGBQuadArray: TRGBQuadArray256; var Index: integer);
514 | var i: integer;
515 | begin
516 | if Node.IsLeaf then
517 | begin
518 | with RGBQuadArray[Index] do
519 | begin
520 | try
521 | r := Byte(Node.RedSum div Node.PixelCount);
522 | g := Byte(Node.GreenSum div Node.PixelCount);
523 | b := Byte(Node.BlueSum div Node.PixelCount);
524 | a := 0;
525 | except
526 | r := 0;
527 | g := 0;
528 | b := 0;
529 | a := 0;
530 | end;
531 | a := 0
532 | end;
533 | inc(Index);
534 | end
535 | else
536 | for i := Low(Node.Child) to High(Node.Child) do
537 | if Node.Child[i] <> nil then
538 | GetPaletteColors(Node.Child[i], RGBQuadArray, Index)
539 | end;
540 |
541 | procedure SetPalette(Pal: array of TColor; Size: integer);
542 | var
543 | PalSize, i: integer;
544 | Col: PFPCompactImgRGB8BitValue;
545 | x, y: Cardinal;
546 | Red, Green, Blue: Byte;
547 | Pcol: PInteger;
548 | DistanceSquared, SmallestDistanceSquared: integer;
549 | R1, G1, B1: Byte;
550 | begin
551 | if Size <> -1 then PalSize := Size else PalSize := High(Pal) + 1;
552 | for i := 0 to PalSize - 1 do
553 | begin
554 | GetMem(Col, SizeOf(TFPCompactImgRGB8BitValue));
555 | Col^.r := Byte(Pal[i]);
556 | Col^.g := Byte(Pal[i] shr 8);
557 | Col^.b := Byte(Pal[i] shr 16);
558 | Palette.Add(Col);
559 | end;
560 | for y := 0 to $ff do
561 | for x := 0 to $ff do
562 | Mappings[y,x] := nil;
563 | for y := 0 to Img.Height - 1 do
564 | for x := 0 to Img.Width - 1 do
565 | begin
566 | Red := Byte(Img.Colors[x, y].red shr 8);
567 | Green := Byte(Img.Colors[x, y].green shr 8);
568 | Blue := Byte(Img.Colors[x, y].blue shr 8);
569 | //Small reduction of color space
570 | dec(Red, Red mod 3);
571 | dec(Green, Green mod 3);
572 | dec(Blue, Blue mod 3);
573 | if (Mappings[Red, Green]) = nil then
574 | begin
575 | Mappings[Red, Green] := TList.Create;
576 | Mappings[Red, Green].Count := 256;
577 | end;
578 | if (Mappings[Red, Green].Items[Blue] = nil) then
579 | begin
580 | GetMem(Pcol, SizeOf(integer));
581 | PCol^ := 0;
582 | SmallestDistanceSquared := $1000000;
583 | for i := 0 to Palette.Count - 1 do
584 | begin
585 | R1 := PFPCompactImgRGB8BitValue(Palette[i])^.r;
586 | G1 := PFPCompactImgRGB8BitValue(Palette[i])^.g;
587 | B1 := PFPCompactImgRGB8BitValue(Palette[i])^.b;
588 | DistanceSquared := (Red - R1) * (Red - R1) + (Green - G1) * (Green - G1) + (Blue - B1) * (Blue - B1);
589 | if DistanceSquared < SmallestDistanceSquared then
590 | begin
591 | PCol^ := i;
592 | if (Red = R1) and (Green = G1) and (Blue = B1) then break;
593 | SmallestDistanceSquared := DistanceSquared;
594 | end
595 | end;
596 | Mappings[Red, Green].Items[Blue] := PCol;
597 | end;
598 | end;
599 | end;
600 |
601 | procedure DeleteTree(var Node: TOctreeNode);
602 | var i: integer;
603 | begin
604 | for i := Low(TReducibleNodes) to High(TReducibleNodes) do
605 | if Node.Child[i] <> nil then
606 | DeleteTree(Node.Child[i]);
607 | FreeAndNil(Node);
608 | end;
609 |
610 | var
611 | i, j, Index: integer;
612 | QArr: TRGBQuadArray256;
613 | begin
614 | PaletteHasAllColours := false;
615 | Tree := nil;
616 | LeafCount := 0;
617 | for i := Low(ReducibleNodes) to High(ReducibleNodes) do
618 | ReducibleNodes[i] := nil;
619 | if (Img.Height > 0) and (Img.Width > 0) then
620 | for j := 0 to Img.Height - 1 do
621 | for i := 0 to Img.Width - 1 do
622 | begin
623 | AddColor(Tree, Byte(Img.Colors[i,j].red shr 8), Byte(Img.Colors[i,j].green shr 8), Byte(Img.Colors[i,j].blue shr 8), 0, ReducibleNodes);
624 | while LeafCount > 256 do
625 | ReduceTree(LeafCount, ReducibleNodes)
626 | end;
627 | Index := 0;
628 | GetPaletteColors(Tree, QArr, Index);
629 | for i := 0 to LeafCount - 1 do
630 | CT[i] := (QArr[i].b shl 16) + (QArr[i].g shl 8) + QArr[i].r;
631 | fColorTableSize := LeafCount;
632 | for i := 0 to fColorTableSize - 1 do
633 | fColorTable[i] := CT[i];
634 | LastColor := clNone;
635 | SetPalette(fColorTable, LeafCount);
636 | if Tree <> nil then DeleteTree(Tree);
637 | end;
638 |
639 | procedure ClearMappings;
640 | var i, j, k: integer;
641 | begin
642 | for j := 0 to $FF do
643 | for i := 0 to $FF do
644 | begin
645 | if Assigned(Mappings[i, j]) then
646 | begin
647 | for k := 0 to $FF do
648 | FreeMem(Mappings[i, j].Items[k], SizeOf(TColor));
649 | Mappings[i, j].Free;
650 | end;
651 | Mappings[i, j] := nil;
652 | end;
653 | end;
654 |
655 | procedure SetPixel(X, Y: Integer; Value: TColor);
656 | var
657 | Val: integer;
658 | PCol: PInteger;
659 | R, G, B: byte;
660 | begin
661 | if not ((Img.Width >= X) and (Img.Height >= Y) and (X > -1) and (Y > -1)) then exit;
662 | Val := -1;
663 | if LastColor = Value then
664 | Val := LastColorIndex
665 | else
666 | begin
667 | if PaletteHasAllColours then
668 | begin
669 | TFPCompactImgRGBA8BitValue(Value).a := 0;
670 | for Val := 0 to fColorTableSize - 1 do
671 | if fColorTable[Val] = Value then break;
672 | end
673 | else
674 | begin
675 | B := Byte(Value shr 16);
676 | B := B - (B mod 3);
677 | G := Byte(Value shr 8);
678 | G := G - (G mod 3);
679 | R := Byte(Value);
680 | R := R - (R mod 3);
681 | Val := -1;
682 | if Mappings[R, G] <> nil then
683 | begin
684 | PCol := Mappings[R, G].Items[B];
685 | if PCol <> nil then Val := PCol^;
686 | end;
687 | end;
688 | LastColor := Value;
689 | LastColorIndex := Val;
690 | end;
691 | fPixels^[Y * Img.Width + X] := Val;
692 | end;
693 |
694 | // find the color within the color table; returns 0..255, -1 if color not found
695 | function FindColorIndex(c: TColor): integer;
696 | var i: integer;
697 | begin
698 | i := 0;
699 | result := -1;
700 | while (i -1) then
808 | begin
809 | Packedbit := Packedbit or $01; // transparent color given (Packedbit or $01)
810 | ColorIndex := n; //transparent color index
811 | end;
812 | end;
813 | DelayTime := 0;
814 | Terminator := 0; // allways 0
815 | end;
816 |
817 | SaveToStream(Stream);
818 |
819 | if (fPixelList <> nil) then FreeMem(fPixelList);
820 | FreeMem(fPixels);
821 | fPixels := nil;
822 | end;
823 | {$ENDREGION}
824 |
825 | initialization
826 | ImageHandlers.RegisterImageWriter ('GIF Graphics', 'gif', TFPWriterGif);
827 | end.
828 |
--------------------------------------------------------------------------------
/icons/Farm-Fresh_clipboard_empty.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/Farm-Fresh_clipboard_empty.png
--------------------------------------------------------------------------------
/icons/browse.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/browse.png
--------------------------------------------------------------------------------
/icons/clip1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/clip1.png
--------------------------------------------------------------------------------
/icons/clip_copy.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/clip_copy.png
--------------------------------------------------------------------------------
/icons/color.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/color.png
--------------------------------------------------------------------------------
/icons/color_pick.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/color_pick.png
--------------------------------------------------------------------------------
/icons/copy.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/copy.png
--------------------------------------------------------------------------------
/icons/delete.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/delete.png
--------------------------------------------------------------------------------
/icons/filter.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/filter.png
--------------------------------------------------------------------------------
/icons/flip.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/flip.png
--------------------------------------------------------------------------------
/icons/fullscreen.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/fullscreen.png
--------------------------------------------------------------------------------
/icons/open.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/open.png
--------------------------------------------------------------------------------
/icons/options.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/options.png
--------------------------------------------------------------------------------
/icons/print.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/print.png
--------------------------------------------------------------------------------
/icons/refresh.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/refresh.png
--------------------------------------------------------------------------------
/icons/resize.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/resize.png
--------------------------------------------------------------------------------
/icons/rotate180.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/rotate180.png
--------------------------------------------------------------------------------
/icons/rotate270.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/rotate270.png
--------------------------------------------------------------------------------
/icons/rotate90.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/rotate90.png
--------------------------------------------------------------------------------
/icons/save.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/save.png
--------------------------------------------------------------------------------
/icons/screenshot.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/screenshot.png
--------------------------------------------------------------------------------
/icons/url.txt:
--------------------------------------------------------------------------------
1 | https://commons.wikimedia.org/wiki/Farm-Fresh_web_icons
2 | + custom modifications
--------------------------------------------------------------------------------
/icons/zoom100.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/zoom100.png
--------------------------------------------------------------------------------
/icons/zoom_in.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/zoom_in.png
--------------------------------------------------------------------------------
/icons/zoom_out.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/icons/zoom_out.png
--------------------------------------------------------------------------------
/project1.ico:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PascalVault/Lazzy_Image_Viewer/20531cd256d6b99259a4aac3656762208c852759/project1.ico
--------------------------------------------------------------------------------
/project1.lpi:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 | -
29 |
30 |
31 | -
32 |
33 |
34 |
35 |
36 |
37 |
38 |
39 |
40 |
41 |
42 |
43 |
44 |
45 |
46 |
47 |
48 |
49 |
50 |
51 |
52 |
53 |
54 |
55 |
56 |
57 |
58 |
59 |
60 |
61 |
62 |
63 |
64 |
65 |
66 |
67 |
68 |
69 |
70 |
71 |
72 |
73 |
74 |
75 |
76 |
77 |
78 |
79 |
80 |
81 |
82 |
83 |
84 |
85 |
86 |
87 |
88 |
89 |
90 |
91 |
92 |
93 |
94 |
95 |
96 |
97 |
98 |
99 |
100 |
101 |
102 |
103 |
104 |
105 |
106 |
107 |
108 |
109 |
110 |
111 |
112 |
113 |
114 |
115 |
116 |
117 |
118 |
119 |
120 |
121 | -
122 |
123 |
124 | -
125 |
126 |
127 | -
128 |
129 |
130 |
131 |
132 |
133 |
--------------------------------------------------------------------------------
/project1.lpr:
--------------------------------------------------------------------------------
1 | program project1;
2 |
3 | {$mode objfpc}{$H+}
4 |
5 | uses
6 | {$IFDEF UNIX}
7 | cthreads,
8 | {$ENDIF}
9 | {$IFDEF HASAMIGA}
10 | athreads,
11 | {$ENDIF}
12 | Interfaces, // this includes the LCL widgetset
13 | Forms, printer4lazarus, unit1, dlg_colors, dlg_params, dlg_resize, dlg_about,
14 | dlg_info, dlg_formats
15 | { you can add units after this };
16 |
17 | {$R *.res}
18 |
19 | begin
20 | RequireDerivedFormResource:=True;
21 | Application.Title:='Lazzy Image Viewer';
22 | Application.Scaled:=True;
23 | Application.Initialize;
24 | Application.CreateForm(TForm1, Form1);
25 | Application.CreateForm(TColorsDlg, ColorsDlg);
26 | Application.CreateForm(TParamsDlg, ParamsDlg);
27 | Application.CreateForm(TResizeDlg, ResizeDlg);
28 | Application.CreateForm(TAboutDlg, AboutDlg);
29 | Application.CreateForm(TInfoDlg, InfoDlg);
30 | Application.CreateForm(TFormatsDlg, FormatsDlg);
31 | Application.Run;
32 | end.
33 |
34 |
--------------------------------------------------------------------------------