├── .gitattributes ├── .gitignore ├── LICENSE ├── README.md ├── buildres.bat ├── memory.pas ├── project1.ico ├── project1.lpi ├── project1.lpr ├── project1.lps ├── project1.res ├── reclist.pas ├── unicodehelper.pas ├── vtxcolordlg.lfm ├── vtxcolordlg.lrs ├── vtxcolordlg.pas ├── vtxconst.pas ├── vtxcursors.lrs ├── vtxedit.ico ├── vtxedit.ini ├── vtxedit.lfm ├── vtxedit.lrs ├── vtxedit.pas ├── vtxencdetect.pas ├── vtxexportoptions.lfm ├── vtxexportoptions.lrs ├── vtxexportoptions.pas ├── vtxpreviewbox.lfm ├── vtxpreviewbox.pas ├── vtxsupport.pas └── work ├── MicroKnightPlus_v1.0.raw ├── MicroKnight_v1.0.raw ├── P0T-NOoDLE_v1.0.raw ├── TopazPlus_a1200_v1.0.raw ├── TopazPlus_a500_v1.0.raw ├── Topaz_a1200_v1.0.raw ├── Topaz_a500_v1.0.raw ├── c0.cur ├── c0.png ├── c1.cur ├── c1.png ├── c2.cur ├── c2.png ├── c3.cur ├── c3.png ├── c4.cur ├── c4.png ├── c5.cur ├── c5.png ├── c6.cur ├── c6.png ├── c7.cur ├── c7.png ├── c8.cur ├── c8.png ├── c9.cur ├── c9.png ├── cursors.png ├── grayicons.png ├── icons.cdr ├── icons.png ├── mO'sOul_v1.0.raw └── u_vga16.bdf /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Created by https://www.gitignore.io/api/windows,lazarus,freepascal 2 | 3 | ### FreePascal ### 4 | *.lps 5 | *.compiled 6 | *.[oa] 7 | *.ppu 8 | *.rst 9 | *.cgi 10 | *.exe 11 | *.log 12 | tabs.ini 13 | *.bak* 14 | fp.ini 15 | fp.cfg 16 | fp.dsk 17 | 18 | ### Lazarus ### 19 | # Lazarus compiler-generated binaries (safe to delete) 20 | *.dll 21 | *.so 22 | *.dylib 23 | *.res 24 | *.dbg 25 | *.o 26 | *.or 27 | *.a 28 | 29 | # Lazarus autogenerated files (duplicated info) 30 | *.rsj 31 | *.lrt 32 | 33 | # Lazarus local files (user-specific info) 34 | *.lps 35 | 36 | # Lazarus backups and unit output folders. 37 | # These can be changed by user in Lazarus/project options. 38 | backup/ 39 | *.bak 40 | lib/ 41 | 42 | # Application bundle for Mac OS 43 | *.app/ 44 | 45 | ### Windows ### 46 | # Windows thumbnail cache files 47 | Thumbs.db 48 | ehthumbs.db 49 | ehthumbs_vista.db 50 | 51 | # Folder config file 52 | Desktop.ini 53 | 54 | # Recycle Bin used on file shares 55 | $RECYCLE.BIN/ 56 | 57 | # Windows Installer files 58 | *.cab 59 | *.msi 60 | *.msm 61 | *.msp 62 | 63 | # Windows shortcuts 64 | *.lnk 65 | 66 | # CorelDraw backups 67 | Backup_of_* 68 | 69 | # End of https://www.gitignore.io/api/windows,lazarus,freepascal 70 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 2017, Daniel Mecklenburg Jr. 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VTXEdit 2 | VTX ANSI Editor. 3 | 4 | ## Building 5 | ### Dependencies 6 | * Package: [BGRABitmapPack](https://github.com/bgrabitmap/bgrabitmap/) 7 | 8 | #### Linux 9 | You will need at least the following libs (packages listed for Ubuntu type distros; adjust accordingly): 10 | ``` 11 | sudo apt-get install libgtk2.0-dev 12 | ``` 13 | -------------------------------------------------------------------------------- /buildres.bat: -------------------------------------------------------------------------------- 1 | rem need appropriate script for linux 2 | rem lazres is in the lazarus\tools path 3 | 4 | @echo off 5 | 6 | set PATH=%PATH%;C:\lazarus\tools; 7 | 8 | echo work\c0.cur > lrs.tmp 9 | echo work\c1.cur >> lrs.tmp 10 | echo work\c2.cur >> lrs.tmp 11 | echo work\c3.cur >> lrs.tmp 12 | echo work\c4.cur >> lrs.tmp 13 | echo work\c5.cur >> lrs.tmp 14 | echo work\c6.cur >> lrs.tmp 15 | echo work\c7.cur >> lrs.tmp 16 | echo work\c8.cur >> lrs.tmp 17 | echo work\c9.cur >> lrs.tmp 18 | rem echo work\c4.cur >> lrs.tmp 19 | 20 | lazres vtxcursors.lrs @lrs.tmp 21 | 22 | del lrs.tmp 23 | -------------------------------------------------------------------------------- /memory.pas: -------------------------------------------------------------------------------- 1 | { 2 | 3 | BSD 2-Clause License 4 | 5 | Copyright (c) 2017, Daniel Mecklenburg Jr. All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | } 29 | 30 | unit Memory; 31 | 32 | {$mode objfpc}{$H+} 33 | {$modeswitch advancedrecords} 34 | {$ASMMODE intel} 35 | 36 | interface 37 | 38 | uses 39 | Classes, SysUtils; 40 | 41 | procedure MemZero(dst : Pointer; size : longint); inline; 42 | procedure MemFill(dst : Pointer; size : longint; val : byte); inline; 43 | procedure MemCopy(src, dst : Pointer; size : longint); inline; 44 | function MemComp(src, dst : Pointer; size : longint) : boolean; inline; 45 | 46 | implementation 47 | 48 | procedure MemZero(dst : Pointer; size : longint); inline; 49 | begin 50 | FillByte(dst^, size, $00); 51 | // asm 52 | // MOV EDI, dst 53 | // MOV ECX, size 54 | // XOR AL, AL 55 | // REP STOSB 56 | // end ['AL', 'EDI', 'ECX']; 57 | end; 58 | 59 | procedure MemFill(dst : Pointer; size : longint; val : byte); inline; 60 | begin 61 | FillByte(dst^, size, val); 62 | // asm 63 | // MOV EDI, dst 64 | // MOV ECX, size 65 | // MOV AL, val 66 | // REP STOSB 67 | // end ['AL', 'EDI', 'ECX']; 68 | end; 69 | 70 | procedure MemCopy(src, dst : Pointer; size : longint); inline; 71 | begin 72 | Move(src^, dst^, size); 73 | // asm 74 | // MOV ESI, src 75 | // MOV EDI, dst 76 | // MOV ECX, size 77 | // REP MOVSB 78 | // end ['ESI', 'EDI', 'ECX']; 79 | end; 80 | 81 | function MemComp(src, dst : Pointer; size : longint) : boolean; inline; 82 | //label 83 | // done; 84 | begin 85 | result := CompareMem(src,dst,size); 86 | // asm 87 | // MOV result, $01 88 | // MOV ESI, src 89 | // MOV EDI, dst 90 | // MOV ECX, size 91 | // REPE CMPSB 92 | // JZ DONE 93 | // DEC result 94 | //DONE: 95 | // end; 96 | end; 97 | 98 | end. 99 | 100 | -------------------------------------------------------------------------------- /project1.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/project1.ico -------------------------------------------------------------------------------- /project1.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | <UseXPManifest Value="True"/> 16 | <Icon Value="0"/> 17 | <Resources Count="5"> 18 | <Resource_0 FileName="work\c0.cur" Type="CURSOR" ResourceName="C0"/> 19 | <Resource_1 FileName="work\c1.cur" Type="CURSOR" ResourceName="C1"/> 20 | <Resource_2 FileName="work\c2.cur" Type="CURSOR" ResourceName="C2"/> 21 | <Resource_3 FileName="work\c3.cur" Type="CURSOR" ResourceName="C3"/> 22 | <Resource_4 FileName="work\c4.cur" Type="CURSOR" ResourceName="C4"/> 23 | </Resources> 24 | </General> 25 | <i18n> 26 | <EnableI18N LFM="False"/> 27 | </i18n> 28 | <VersionInfo> 29 | <StringTable ProductVersion=""/> 30 | </VersionInfo> 31 | <BuildModes Count="1"> 32 | <Item1 Name="Default" Default="True"/> 33 | </BuildModes> 34 | <PublishOptions> 35 | <Version Value="2"/> 36 | </PublishOptions> 37 | <RunParams> 38 | <local> 39 | <FormatVersion Value="1"/> 40 | </local> 41 | </RunParams> 42 | <RequiredPackages Count="4"> 43 | <Item1> 44 | <PackageName Value="SynEdit"/> 45 | </Item1> 46 | <Item2> 47 | <PackageName Value="DateTimeCtrls"/> 48 | </Item2> 49 | <Item3> 50 | <PackageName Value="BGRABitmapPack"/> 51 | </Item3> 52 | <Item4> 53 | <PackageName Value="LCL"/> 54 | </Item4> 55 | </RequiredPackages> 56 | <Units Count="14"> 57 | <Unit0> 58 | <Filename Value="project1.lpr"/> 59 | <IsPartOfProject Value="True"/> 60 | </Unit0> 61 | <Unit1> 62 | <Filename Value="vtxedit.pas"/> 63 | <IsPartOfProject Value="True"/> 64 | <ComponentName Value="fMain"/> 65 | <HasResources Value="True"/> 66 | <ResourceBaseClass Value="Form"/> 67 | <UnitName Value="VTXEdit"/> 68 | </Unit1> 69 | <Unit2> 70 | <Filename Value="vtxconst.pas"/> 71 | <IsPartOfProject Value="True"/> 72 | <UnitName Value="VTXConst"/> 73 | </Unit2> 74 | <Unit3> 75 | <Filename Value="vtxpreviewbox.pas"/> 76 | <IsPartOfProject Value="True"/> 77 | <ComponentName Value="fPreview"/> 78 | <HasResources Value="True"/> 79 | <ResourceBaseClass Value="Form"/> 80 | <UnitName Value="VTXPreviewBox"/> 81 | </Unit3> 82 | <Unit4> 83 | <Filename Value="vtxsupport.pas"/> 84 | <IsPartOfProject Value="True"/> 85 | <UnitName Value="VTXSupport"/> 86 | </Unit4> 87 | <Unit5> 88 | <Filename Value="vtxedit.ini"/> 89 | <IsPartOfProject Value="True"/> 90 | </Unit5> 91 | <Unit6> 92 | <Filename Value="vtxencdetect.pas"/> 93 | <IsPartOfProject Value="True"/> 94 | <UnitName Value="VTXEncDetect"/> 95 | </Unit6> 96 | <Unit7> 97 | <Filename Value="unicodehelper.pas"/> 98 | <IsPartOfProject Value="True"/> 99 | <UnitName Value="UnicodeHelper"/> 100 | </Unit7> 101 | <Unit8> 102 | <Filename Value="reclist.pas"/> 103 | <IsPartOfProject Value="True"/> 104 | <UnitName Value="RecList"/> 105 | </Unit8> 106 | <Unit9> 107 | <Filename Value="memory.pas"/> 108 | <IsPartOfProject Value="True"/> 109 | <UnitName Value="Memory"/> 110 | </Unit9> 111 | <Unit10> 112 | <Filename Value="vtxcursors.lrs"/> 113 | <IsPartOfProject Value="True"/> 114 | </Unit10> 115 | <Unit11> 116 | <Filename Value="buildres.bat"/> 117 | <IsPartOfProject Value="True"/> 118 | </Unit11> 119 | <Unit12> 120 | <Filename Value="vtxexportoptions.pas"/> 121 | <IsPartOfProject Value="True"/> 122 | <ComponentName Value="fExportOptions"/> 123 | <HasResources Value="True"/> 124 | <ResourceBaseClass Value="Form"/> 125 | <UnitName Value="VTXExportOptions"/> 126 | </Unit12> 127 | <Unit13> 128 | <Filename Value="vtxcolordlg.pas"/> 129 | <IsPartOfProject Value="True"/> 130 | <ComponentName Value="fColorDialog"/> 131 | <HasResources Value="True"/> 132 | <ResourceBaseClass Value="Form"/> 133 | <UnitName Value="VTXColorDlg"/> 134 | </Unit13> 135 | </Units> 136 | </ProjectOptions> 137 | <CompilerOptions> 138 | <Version Value="11"/> 139 | <PathDelim Value="\"/> 140 | <Target> 141 | <Filename Value="vtxedit"/> 142 | </Target> 143 | <SearchPaths> 144 | <IncludeFiles Value="$(ProjOutDir)"/> 145 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 146 | </SearchPaths> 147 | <Linking> 148 | <Debugging> 149 | <UseHeaptrc Value="True"/> 150 | </Debugging> 151 | <Options> 152 | <Win32> 153 | <GraphicApplication Value="True"/> 154 | </Win32> 155 | </Options> 156 | </Linking> 157 | <Other> 158 | <Verbosity> 159 | <ShoLineNum Value="True"/> 160 | <ShowAll Value="True"/> 161 | <ShowDebugInfo Value="True"/> 162 | <ShowUsedFiles Value="True"/> 163 | <ShowTriedFiles Value="True"/> 164 | <ShowCompProc Value="True"/> 165 | <ShowCond Value="True"/> 166 | <ShowExecInfo Value="True"/> 167 | <ShowHintsForUnusedUnitsInMainSrc Value="True"/> 168 | <ShowHintsForSenderNotUsed Value="True"/> 169 | </Verbosity> 170 | </Other> 171 | </CompilerOptions> 172 | <Debugging> 173 | <Exceptions Count="4"> 174 | <Item1> 175 | <Name Value="EAbort"/> 176 | </Item1> 177 | <Item2> 178 | <Name Value="ECodetoolError"/> 179 | </Item2> 180 | <Item3> 181 | <Name Value="EFOpenError"/> 182 | </Item3> 183 | <Item4> 184 | <Name Value="RunError(201)"/> 185 | </Item4> 186 | </Exceptions> 187 | </Debugging> 188 | </CONFIG> 189 | -------------------------------------------------------------------------------- /project1.lpr: -------------------------------------------------------------------------------- 1 | { 2 | 3 | BSD 2-Clause License 4 | 5 | Copyright (c) 2017, Daniel Mecklenburg Jr. All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | } 29 | 30 | program project1; 31 | 32 | {$mode objfpc}{$H+} 33 | 34 | uses 35 | {$IFDEF UNIX}{$IFDEF UseCThreads} 36 | cthreads, 37 | {$ENDIF}{$ENDIF} 38 | Interfaces, // this includes the LCL widgetset 39 | Forms, 40 | VTXEdit; 41 | 42 | {$R *.res} 43 | 44 | begin 45 | Application.Title:='VTXEdit'; 46 | RequireDerivedFormResource:=True; 47 | Application.Initialize; 48 | Application.CreateForm(TfMain, fMain); 49 | Application.Run; 50 | end. 51 | 52 | 53 | -------------------------------------------------------------------------------- /project1.lps: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectSession> 4 | <PathDelim Value="\"/> 5 | <Version Value="10"/> 6 | <BuildModes Active="Default"/> 7 | <Units Count="29"> 8 | <Unit0> 9 | <Filename Value="project1.lpr"/> 10 | <IsPartOfProject Value="True"/> 11 | <EditorIndex Value="-1"/> 12 | <CursorPos X="10" Y="40"/> 13 | <UsageCount Value="147"/> 14 | </Unit0> 15 | <Unit1> 16 | <Filename Value="vtxedit.pas"/> 17 | <IsPartOfProject Value="True"/> 18 | <ComponentName Value="fMain"/> 19 | <HasResources Value="True"/> 20 | <ResourceBaseClass Value="Form"/> 21 | <UnitName Value="VTXEdit"/> 22 | <TopLine Value="9931"/> 23 | <CursorPos X="6" Y="10017"/> 24 | <UsageCount Value="147"/> 25 | <Loaded Value="True"/> 26 | <LoadedDesigner Value="True"/> 27 | </Unit1> 28 | <Unit2> 29 | <Filename Value="vtxconst.pas"/> 30 | <IsPartOfProject Value="True"/> 31 | <UnitName Value="VTXConst"/> 32 | <IsVisibleTab Value="True"/> 33 | <EditorIndex Value="10"/> 34 | <TopLine Value="9972"/> 35 | <CursorPos Y="10058"/> 36 | <UsageCount Value="147"/> 37 | <Loaded Value="True"/> 38 | </Unit2> 39 | <Unit3> 40 | <Filename Value="vtxpreviewbox.pas"/> 41 | <IsPartOfProject Value="True"/> 42 | <ComponentName Value="fPreview"/> 43 | <HasResources Value="True"/> 44 | <ResourceBaseClass Value="Form"/> 45 | <UnitName Value="VTXPreviewBox"/> 46 | <EditorIndex Value="1"/> 47 | <CursorPos Y="91"/> 48 | <UsageCount Value="147"/> 49 | <Loaded Value="True"/> 50 | <LoadedDesigner Value="True"/> 51 | </Unit3> 52 | <Unit4> 53 | <Filename Value="vtxsupport.pas"/> 54 | <IsPartOfProject Value="True"/> 55 | <UnitName Value="VTXSupport"/> 56 | <EditorIndex Value="9"/> 57 | <TopLine Value="327"/> 58 | <CursorPos X="18" Y="431"/> 59 | <UsageCount Value="147"/> 60 | <Loaded Value="True"/> 61 | </Unit4> 62 | <Unit5> 63 | <Filename Value="vtxedit.ini"/> 64 | <IsPartOfProject Value="True"/> 65 | <UsageCount Value="147"/> 66 | </Unit5> 67 | <Unit6> 68 | <Filename Value="vtxencdetect.pas"/> 69 | <IsPartOfProject Value="True"/> 70 | <UnitName Value="VTXEncDetect"/> 71 | <UsageCount Value="147"/> 72 | </Unit6> 73 | <Unit7> 74 | <Filename Value="unicodehelper.pas"/> 75 | <IsPartOfProject Value="True"/> 76 | <UnitName Value="UnicodeHelper"/> 77 | <EditorIndex Value="-1"/> 78 | <TopLine Value="310"/> 79 | <CursorPos Y="334"/> 80 | <UsageCount Value="147"/> 81 | </Unit7> 82 | <Unit8> 83 | <Filename Value="reclist.pas"/> 84 | <IsPartOfProject Value="True"/> 85 | <UnitName Value="RecList"/> 86 | <EditorIndex Value="8"/> 87 | <TopLine Value="124"/> 88 | <CursorPos X="41" Y="203"/> 89 | <UsageCount Value="147"/> 90 | <Loaded Value="True"/> 91 | </Unit8> 92 | <Unit9> 93 | <Filename Value="memory.pas"/> 94 | <IsPartOfProject Value="True"/> 95 | <UnitName Value="Memory"/> 96 | <UsageCount Value="147"/> 97 | </Unit9> 98 | <Unit10> 99 | <Filename Value="vtxcursors.lrs"/> 100 | <IsPartOfProject Value="True"/> 101 | <UsageCount Value="147"/> 102 | </Unit10> 103 | <Unit11> 104 | <Filename Value="buildres.bat"/> 105 | <IsPartOfProject Value="True"/> 106 | <UsageCount Value="147"/> 107 | </Unit11> 108 | <Unit12> 109 | <Filename Value="vtxexportoptions.pas"/> 110 | <IsPartOfProject Value="True"/> 111 | <ComponentName Value="fExportOptions"/> 112 | <HasResources Value="True"/> 113 | <ResourceBaseClass Value="Form"/> 114 | <UnitName Value="VTXExportOptions"/> 115 | <UsageCount Value="147"/> 116 | </Unit12> 117 | <Unit13> 118 | <Filename Value="vtxcolordlg.pas"/> 119 | <IsPartOfProject Value="True"/> 120 | <ComponentName Value="fColorDialog"/> 121 | <HasResources Value="True"/> 122 | <ResourceBaseClass Value="Form"/> 123 | <UnitName Value="VTXColorDlg"/> 124 | <EditorIndex Value="2"/> 125 | <TopLine Value="223"/> 126 | <CursorPos Y="286"/> 127 | <UsageCount Value="48"/> 128 | <Loaded Value="True"/> 129 | <LoadedDesigner Value="True"/> 130 | </Unit13> 131 | <Unit14> 132 | <Filename Value="vtxfontconfig.pas"/> 133 | <ComponentName Value="fFontConfig"/> 134 | <HasResources Value="True"/> 135 | <ResourceBaseClass Value="Form"/> 136 | <UnitName Value="VTXFontConfig"/> 137 | <EditorIndex Value="-1"/> 138 | <UsageCount Value="110"/> 139 | </Unit14> 140 | <Unit15> 141 | <Filename Value="C:\lazarus\lcl\stdctrls.pp"/> 142 | <UnitName Value="StdCtrls"/> 143 | <EditorIndex Value="-1"/> 144 | <TopLine Value="915"/> 145 | <CursorPos X="14" Y="937"/> 146 | <UsageCount Value="5"/> 147 | </Unit15> 148 | <Unit16> 149 | <Filename Value="C:\lazarus\fpc\3.0.2\source\rtl\objpas\classes\classesh.inc"/> 150 | <EditorIndex Value="-1"/> 151 | <TopLine Value="635"/> 152 | <CursorPos X="15" Y="673"/> 153 | <UsageCount Value="8"/> 154 | </Unit16> 155 | <Unit17> 156 | <Filename Value="C:\lazarus\lcl\include\control.inc"/> 157 | <EditorIndex Value="-1"/> 158 | <TopLine Value="2057"/> 159 | <CursorPos X="16" Y="2161"/> 160 | <UsageCount Value="6"/> 161 | </Unit17> 162 | <Unit18> 163 | <Filename Value="C:\lazarus\lcl\include\customlistview.inc"/> 164 | <EditorIndex Value="-1"/> 165 | <UsageCount Value="22"/> 166 | </Unit18> 167 | <Unit19> 168 | <Filename Value="C:\lazarus\lcl\include\fpimagebitmap.inc"/> 169 | <EditorIndex Value="-1"/> 170 | <TopLine Value="71"/> 171 | <CursorPos Y="121"/> 172 | <UsageCount Value="19"/> 173 | </Unit19> 174 | <Unit20> 175 | <Filename Value="C:\lazarus\lcl\dialogs.pp"/> 176 | <UnitName Value="Dialogs"/> 177 | <EditorIndex Value="-1"/> 178 | <TopLine Value="179"/> 179 | <CursorPos X="3" Y="235"/> 180 | <UsageCount Value="10"/> 181 | </Unit20> 182 | <Unit21> 183 | <Filename Value="C:\lazarus\lcl\include\customform.inc"/> 184 | <EditorIndex Value="6"/> 185 | <TopLine Value="1931"/> 186 | <CursorPos Y="1987"/> 187 | <UsageCount Value="21"/> 188 | <Loaded Value="True"/> 189 | </Unit21> 190 | <Unit22> 191 | <Filename Value="vtxcolordlg.lfm"/> 192 | <EditorIndex Value="7"/> 193 | <UsageCount Value="21"/> 194 | <Loaded Value="True"/> 195 | <DefaultSyntaxHighlighter Value="LFM"/> 196 | </Unit22> 197 | <Unit23> 198 | <Filename Value="..\..\Pascal\Retroize\unit2.pas"/> 199 | <UnitName Value="Unit2"/> 200 | <EditorIndex Value="4"/> 201 | <UsageCount Value="20"/> 202 | <Loaded Value="True"/> 203 | </Unit23> 204 | <Unit24> 205 | <Filename Value="..\..\Pascal\Retroize\unit3.pas"/> 206 | <UnitName Value="Unit3"/> 207 | <EditorIndex Value="5"/> 208 | <TopLine Value="639"/> 209 | <CursorPos Y="738"/> 210 | <UsageCount Value="20"/> 211 | <Loaded Value="True"/> 212 | </Unit24> 213 | <Unit25> 214 | <Filename Value="C:\lazarus\lcl\lclproc.pas"/> 215 | <UnitName Value="LCLProc"/> 216 | <EditorIndex Value="-1"/> 217 | <TopLine Value="846"/> 218 | <CursorPos Y="902"/> 219 | <UsageCount Value="10"/> 220 | </Unit25> 221 | <Unit26> 222 | <Filename Value="C:\lazarus\components\bgrabitmap\bgradefaultbitmap.pas"/> 223 | <UnitName Value="BGRADefaultBitmap"/> 224 | <EditorIndex Value="-1"/> 225 | <TopLine Value="405"/> 226 | <CursorPos X="15" Y="459"/> 227 | <UsageCount Value="10"/> 228 | </Unit26> 229 | <Unit27> 230 | <Filename Value="C:\lazarus\components\bgrabitmap\bgrapixel.inc"/> 231 | <EditorIndex Value="-1"/> 232 | <TopLine Value="111"/> 233 | <CursorPos X="5" Y="169"/> 234 | <UsageCount Value="10"/> 235 | </Unit27> 236 | <Unit28> 237 | <Filename Value="C:\lazarus\fpc\3.0.2\source\rtl\objpas\sysutils\syshelph.inc"/> 238 | <EditorIndex Value="3"/> 239 | <TopLine Value="35"/> 240 | <CursorPos X="25" Y="121"/> 241 | <UsageCount Value="14"/> 242 | <Loaded Value="True"/> 243 | </Unit28> 244 | </Units> 245 | <JumpHistory Count="30" HistoryIndex="29"> 246 | <Position1> 247 | <Filename Value="vtxedit.pas"/> 248 | </Position1> 249 | <Position2> 250 | <Filename Value="vtxedit.pas"/> 251 | <Caret Line="95" Column="11" TopLine="9"/> 252 | </Position2> 253 | <Position3> 254 | <Filename Value="vtxedit.pas"/> 255 | <Caret Line="3069" Column="6" TopLine="2983"/> 256 | </Position3> 257 | <Position4> 258 | <Filename Value="vtxedit.pas"/> 259 | <Caret Line="3150" Column="6" TopLine="3064"/> 260 | </Position4> 261 | <Position5> 262 | <Filename Value="vtxedit.pas"/> 263 | <Caret Line="3190" Column="6" TopLine="3104"/> 264 | </Position5> 265 | <Position6> 266 | <Filename Value="vtxedit.pas"/> 267 | <Caret Line="6330" Column="6" TopLine="6244"/> 268 | </Position6> 269 | <Position7> 270 | <Filename Value="vtxedit.pas"/> 271 | <Caret Line="6395" Column="6" TopLine="6309"/> 272 | </Position7> 273 | <Position8> 274 | <Filename Value="vtxedit.pas"/> 275 | <Caret Line="6683" Column="6" TopLine="6597"/> 276 | </Position8> 277 | <Position9> 278 | <Filename Value="vtxedit.pas"/> 279 | <Caret Line="7065" Column="6" TopLine="6979"/> 280 | </Position9> 281 | <Position10> 282 | <Filename Value="vtxedit.pas"/> 283 | <Caret Line="7705" Column="6" TopLine="7619"/> 284 | </Position10> 285 | <Position11> 286 | <Filename Value="vtxedit.pas"/> 287 | <Caret Line="8019" Column="6" TopLine="7933"/> 288 | </Position11> 289 | <Position12> 290 | <Filename Value="vtxedit.pas"/> 291 | <Caret Line="8140" Column="6" TopLine="8054"/> 292 | </Position12> 293 | <Position13> 294 | <Filename Value="vtxconst.pas"/> 295 | <Caret Line="418" Column="3" TopLine="361"/> 296 | </Position13> 297 | <Position14> 298 | <Filename Value="vtxconst.pas"/> 299 | </Position14> 300 | <Position15> 301 | <Filename Value="vtxconst.pas"/> 302 | <Caret Line="30" Column="14"/> 303 | </Position15> 304 | <Position16> 305 | <Filename Value="vtxconst.pas"/> 306 | <Caret Line="41" Column="6"/> 307 | </Position16> 308 | <Position17> 309 | <Filename Value="vtxconst.pas"/> 310 | <Caret Line="264" TopLine="176"/> 311 | </Position17> 312 | <Position18> 313 | <Filename Value="vtxconst.pas"/> 314 | </Position18> 315 | <Position19> 316 | <Filename Value="vtxconst.pas"/> 317 | <Caret Line="264" Column="6" TopLine="178"/> 318 | </Position19> 319 | <Position20> 320 | <Filename Value="vtxconst.pas"/> 321 | <Caret Line="265" Column="6" TopLine="179"/> 322 | </Position20> 323 | <Position21> 324 | <Filename Value="vtxconst.pas"/> 325 | <Caret Line="264" Column="6" TopLine="179"/> 326 | </Position21> 327 | <Position22> 328 | <Filename Value="vtxconst.pas"/> 329 | </Position22> 330 | <Position23> 331 | <Filename Value="vtxconst.pas"/> 332 | <Caret Line="83" Column="8"/> 333 | </Position23> 334 | <Position24> 335 | <Filename Value="vtxconst.pas"/> 336 | <Caret Line="92" Column="37" TopLine="6"/> 337 | </Position24> 338 | <Position25> 339 | <Filename Value="vtxconst.pas"/> 340 | <Caret Line="93" Column="8" TopLine="7"/> 341 | </Position25> 342 | <Position26> 343 | <Filename Value="vtxconst.pas"/> 344 | <Caret Line="98" Column="8" TopLine="12"/> 345 | </Position26> 346 | <Position27> 347 | <Filename Value="vtxconst.pas"/> 348 | <Caret Line="99" Column="28" TopLine="13"/> 349 | </Position27> 350 | <Position28> 351 | <Filename Value="vtxconst.pas"/> 352 | <Caret Line="100" Column="52" TopLine="14"/> 353 | </Position28> 354 | <Position29> 355 | <Filename Value="vtxconst.pas"/> 356 | <Caret Line="9985" Column="14" TopLine="9899"/> 357 | </Position29> 358 | <Position30> 359 | <Filename Value="vtxconst.pas"/> 360 | <Caret Line="10033" Column="26" TopLine="9947"/> 361 | </Position30> 362 | </JumpHistory> 363 | </ProjectSession> 364 | <Debugging> 365 | <Watches Count="5"> 366 | <Item1> 367 | <Expression Value="hsl"/> 368 | </Item1> 369 | <Item2> 370 | <Expression Value="rgb"/> 371 | </Item2> 372 | <Item3> 373 | <Expression Value="r"/> 374 | </Item3> 375 | <Item4> 376 | <Expression Value="g"/> 377 | </Item4> 378 | <Item5> 379 | <Expression Value="b"/> 380 | </Item5> 381 | </Watches> 382 | </Debugging> 383 | </CONFIG> 384 | -------------------------------------------------------------------------------- /project1.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/project1.res -------------------------------------------------------------------------------- /reclist.pas: -------------------------------------------------------------------------------- 1 | { 2 | 3 | BSD 2-Clause License 4 | 5 | Copyright (c) 2017, Daniel Mecklenburg Jr. All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | } 29 | 30 | { 31 | Generic record lists using byte buffer data. 32 | } 33 | unit RecList; 34 | 35 | {$mode objfpc}{$H+} 36 | {$modeswitch advancedrecords} 37 | {$asmmode intel} 38 | 39 | interface 40 | 41 | uses 42 | Classes, SysUtils, Memory; 43 | 44 | type 45 | TRecListExpansion = ( rleDoubles, rleAdds ); 46 | 47 | TRecList = record 48 | Data : PBYTE; // pointer to data records 49 | Count : DWORD; // current number of records in Data. 50 | Size : DWORD; // current allocated space 51 | RecSize : DWORD; 52 | Flags : BYTE; 53 | procedure Create(recsz : DWORD; expansion : TRecListExpansion); 54 | procedure Free; 55 | procedure Add(rec : Pointer); // add new record 56 | procedure Remove(recnum : DWORD); 57 | procedure Push(rec : Pointer); 58 | procedure Pop(rec : Pointer); 59 | procedure Put(rec : Pointer; recnum : DWORD); 60 | procedure Get(rec : Pointer; recnum : DWORD); 61 | procedure Clear; 62 | function Copy : TRecList; 63 | procedure Swap(rec1, rec2 : DWORD); 64 | procedure Trim; 65 | function Locked : Boolean; 66 | end; 67 | 68 | implementation 69 | 70 | const 71 | TRECLIST_INITSIZE = 16; // initial number of records allocated on create 72 | TRECLIST_LOCKED = %00000001; // object size is locked. no additions or removals allowed. 73 | TRECLIST_ADDEXPAND = %00000010; // of set, size increases by recsize instead of doubles. 74 | 75 | procedure TRecList.Create(recsz : DWORD; expansion : TRecListExpansion); 76 | begin 77 | self.RecSize := recsz; 78 | self.Count := 0; 79 | self.Size := TRECLIST_INITSIZE; 80 | self.Data := GetMemory(self.RecSize * Size); 81 | FillByte(self.Data[0], self.RecSize * Size, $00); 82 | self.Flags := %00000000; 83 | if expansion = rleAdds then 84 | self.Flags := (self.Flags or TRECLIST_ADDEXPAND); 85 | end; 86 | 87 | function TRecList.Locked : boolean; 88 | begin 89 | result := ((self.Flags and TRECLIST_LOCKED) <> 0); 90 | end; 91 | 92 | procedure TRecList.Free; 93 | begin 94 | if self.Size > 0 then 95 | Freememory(self.Data); 96 | self.Size := 0; 97 | self.Count := 0; 98 | end; 99 | 100 | procedure TRecList.Push(rec : Pointer); 101 | begin 102 | self.Add(rec); 103 | end; 104 | 105 | procedure TRecList.Add(rec : Pointer); 106 | var 107 | newsz : DWORD; 108 | newdata : PBYTE; 109 | begin 110 | 111 | if (self.Flags and TRECLIST_LOCKED) <> 0 then 112 | raise Exception.Create('TRecList Locked.'); 113 | 114 | if Count >= Size then 115 | begin 116 | // grow the data 117 | if (self.Flags and TRECLIST_ADDEXPAND) <> 0 then 118 | newsz := self.Size + (TRECLIST_INITSIZE * self.RecSize) 119 | else 120 | newsz := self.Size << 1; 121 | 122 | newdata := getmemory(newsz * self.RecSize); 123 | MemFill(newdata, newsz * self.RecSize, $00); 124 | MemCopy(self.Data, newdata, self.Size * self.RecSize); 125 | FreeMemory(self.Data); 126 | self.Data := newdata; 127 | self.Size := newsz; 128 | end; 129 | 130 | MemCopy(rec, @self.Data[self.Count * self.RecSize], self.RecSize); 131 | self.Count += 1; 132 | end; 133 | 134 | procedure TRecList.Pop(rec : Pointer); 135 | begin 136 | if self.Count = 0 then 137 | raise Exception.Create('TRecList Stack Underflow.'); 138 | self.Get(rec, self.Count - 1); 139 | self.Count -= 1; 140 | end; 141 | 142 | procedure TRecList.Remove(recnum : DWORD); 143 | var 144 | totsz : DWORD; 145 | endsz : DWORD; 146 | begin 147 | 148 | if (self.Flags and TRECLIST_LOCKED) <> 0 then 149 | raise Exception.Create('TRecList Locked.'); 150 | 151 | if recnum >= self.Count then 152 | raise Exception.Create('TRecList Out of Bounds.'); 153 | 154 | totsz := (self.RecSize * self.Size); 155 | endsz := totsz - ((recnum + 1) * self.RecSize); 156 | move( 157 | self.Data[(recnum + 1) * self.RecSize], 158 | self.Data[recnum * self.RecSize], 159 | endsz); 160 | self.Count -= 1; 161 | end; 162 | 163 | procedure TRecList.Put(rec : Pointer; recnum : DWORD); 164 | begin 165 | if recnum >= self.Count then 166 | raise Exception.Create('TRecList Out of Bounds.'); 167 | 168 | MemCopy(rec, @self.Data[recnum * self.RecSize], self.RecSize); 169 | end; 170 | 171 | procedure TRecList.Get(rec : Pointer; recnum : DWORD); 172 | begin 173 | if recnum >= self.Count then 174 | raise Exception.Create('TRecList Out of Bounds.'); 175 | 176 | MemCopy(@self.Data[recnum * self.RecSize], rec, self.RecSize); 177 | end; 178 | 179 | procedure TRecList.Clear; 180 | begin 181 | FreeMemory(self.Data); 182 | self.Count := 0; 183 | self.Size := TRECLIST_INITSIZE; 184 | self.Data := GetMemory(self.RecSize * Size); 185 | end; 186 | 187 | // create copy of TRecList 188 | // WARNING : CLEAR ANY DATA INSIDE THAT CONTAINS OTHER TRECLISTS 189 | function TRecList.Copy : TRecList; 190 | var 191 | memsize : longint; 192 | begin 193 | result.Count := self.Count; 194 | result.RecSize := self.RecSize; 195 | result.Size := self.Size; 196 | memsize := self.RecSize * self.Size; 197 | result.Data := Getmemory(memsize); 198 | MemCopy(self.Data, result.Data, memsize); 199 | end; 200 | 201 | // swap contents of two recors. 202 | procedure TRecList.Swap(rec1, rec2 : DWORD); 203 | var 204 | idx1, idx2 : DWORD; 205 | tmp : PBYTE; 206 | begin 207 | if (rec1 >= self.Count) or (rec2 >= self.Count) then 208 | raise Exception.Create('TRecList Out of Bounds.'); 209 | 210 | tmp := GetMemory(self.RecSize); 211 | idx1 := rec1 * self.RecSize; 212 | idx2 := rec2 * self.RecSize; 213 | 214 | MemCopy(@self.Data[idx1], tmp, self.RecSize); 215 | MemCopy(@self.Data[idx2], @self.Data[idx1], self.RecSize); 216 | MemCopy(tmp, @self.Data[idx2], self.RecSize); 217 | FreeMemory(tmp); 218 | end; 219 | 220 | // trim memory/ used when rec is not expecet to grow any more. 221 | procedure TRecList.Trim; 222 | var 223 | tmp : PBYTE; 224 | l : DWORD; 225 | begin 226 | l := self.Count * self.RecSize; 227 | tmp := GetMemory(l); 228 | MemCopy(self.Data, tmp, l); 229 | Freememory(self.Data); 230 | self.Data := tmp; 231 | self.Flags := self.Flags or TRECLIST_LOCKED; 232 | end; 233 | 234 | end. 235 | 236 | -------------------------------------------------------------------------------- /unicodehelper.pas: -------------------------------------------------------------------------------- 1 | { 2 | 3 | BSD 2-Clause License 4 | 5 | Copyright (c) 2017, Daniel Mecklenburg Jr. All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | } 29 | 30 | unit UnicodeHelper; 31 | 32 | {$mode objfpc}{$H+} 33 | {$modeswitch typehelpers} 34 | 35 | interface 36 | 37 | uses 38 | SysUtils; 39 | 40 | type 41 | 42 | TUnicodeStringArray = array of UnicodeString; 43 | 44 | TWords = array of Word; 45 | 46 | TWideChars = array of WideChar; 47 | 48 | TWideCharHelper = type helper for WideChar 49 | public 50 | function getUTF8Length : integer; // from 1 to 3 (4=not yet). 51 | function getUTF16Length : integer; // always 2 52 | function getCPLength : integer; // always 1 53 | function toCharCode : integer; 54 | function fromCharCode(chr : integer) : WideChar; 55 | end; 56 | 57 | TUnicodeStringHelper = type helper for UnicodeString 58 | public 59 | function length : integer; overload; 60 | function substring(index : Integer): unicodestring; overload; 61 | function substring(index : Integer; len : Integer): unicodestring; overload; 62 | function charCodeAt(index : integer) : integer; 63 | function charAt(index : integer) : WideChar; 64 | function split(const Separators: array of WideChar): TUnicodeStringArray; overload; 65 | // other String Helper type functions can be added as required. 66 | 67 | function toWideCharArray : TWideChars; 68 | function toWordArray : TWords; 69 | 70 | function toUTF8Bytes : TBytes; 71 | function toUTF16Bytes : TBytes; 72 | function toCPBytes : TBytes; 73 | 74 | function toEncodedCPBytes(table : PWord) : TBytes; 75 | 76 | function getUTF8BytesLength : integer; // varies 77 | function getUTF16BytesLength : integer; // length * 2 78 | function getCPBytesLength : integer; // length 79 | 80 | function fromUTF8Bytes(bytes : TBytes) : UnicodeString; 81 | function fromUTF16Bytes(bytes : TBytes) : UnicodeString; 82 | function fromCPBytes(bytes : TBytes) : UnicodeString; 83 | 84 | function hasUTF8BrokenBytes(bytes : TBytes) : boolean; 85 | function hasUTF16BrokenBytes(bytes : TBytes) : boolean; 86 | function hasCPBrokenBytes(bytes : TBytes) : boolean; // always false 87 | 88 | function getUTF8BrokenBytes(bytes : TBytes) : TBytes; 89 | function getUTF16BrokenBytes(bytes : TBytes) : TBytes; 90 | function getCPBrokenBytes(bytes : TBytes) : TBytes; // always returns [] 91 | 92 | procedure mapCP(map : TWideChars); 93 | end; 94 | 95 | 96 | implementation 97 | 98 | { TWideCHarHelper } 99 | 100 | function TWideCharHelper.getUTF8Length : integer; 101 | begin 102 | if integer(self) < $80 then result := 1 103 | else if integer(self) < $800 then result := 2 104 | else if integer(self) < $10000 then result := 3 105 | else result := 4; 106 | end; 107 | 108 | function TWideCharHelper.getUTF16Length : integer; inline; 109 | begin 110 | result := 2; 111 | end; 112 | 113 | function TWideCharHelper.getCPLength : integer; inline; 114 | begin 115 | result := 1; 116 | end; 117 | 118 | function TWideCharHelper.toCharCode : integer; inline; 119 | begin 120 | result := integer(self); 121 | end; 122 | 123 | function TWideCharHelper.fromCharCode(chr : integer) : WideChar; inline; 124 | begin 125 | result := WideChar(chr); 126 | end; 127 | 128 | { TUnicodeStringHelper } 129 | 130 | { 131 | length : length of the UnicodeString in WideChars. 132 | } 133 | function TUnicodeStringHelper.length : integer; inline; 134 | begin 135 | result := system.length(self); 136 | end; 137 | 138 | function TUnicodeStringHelper.substring(index : Integer): unicodestring; 139 | var 140 | strlen, len : integer; 141 | begin 142 | strlen := self.length; 143 | if (index < 0) or (index >= strlen) then 144 | result := '' 145 | else 146 | begin 147 | len := strlen - index; 148 | setlength(result, len); 149 | move(self[1 + index], result[1], len * sizeof(WideChar)); 150 | end; 151 | end; 152 | 153 | function TUnicodeStringHelper.substring(index : Integer; len : Integer): unicodestring; 154 | var 155 | strlen : integer; 156 | begin 157 | strlen := self.length; 158 | if (index < 0) or (index >= strlen) or (len <= 0) then 159 | result := '' 160 | else 161 | begin 162 | if index + len > strlen then 163 | len := strlen - index; 164 | setlength(result, len); 165 | move(self[1 + index], result[1], len * sizeof(WideChar)); 166 | end; 167 | end; 168 | 169 | function TUnicodeStringHelper.charCodeAt(index : integer) : integer; inline; 170 | begin 171 | if (index < 0) or (index >= self.length) then 172 | result := 0 173 | else 174 | result := self[index + 1].toCharCode; 175 | end; 176 | 177 | function TUnicodeStringHelper.charAt(index : integer) : WideChar; inline; 178 | begin 179 | if (index < 0) or (index >= self.length) then 180 | result := WideChar(0) 181 | else 182 | result := self[index + 1]; 183 | end; 184 | 185 | 186 | Function TUnicodeStringHelper.split(const Separators: array of WideChar): TUnicodeStringArray; 187 | var 188 | i, j, lastpos : integer; 189 | ch : widechar; 190 | 191 | x : UnicodeString; 192 | begin 193 | x := self; 194 | setlength(result, 0); 195 | lastpos := 0; 196 | for i := 0 to self.length - 1 do 197 | begin 198 | ch := self.charAt(i); 199 | for j := 0 to system.length(Separators) - 1 do 200 | begin 201 | if ch = Separators[j] then 202 | begin 203 | setlength(result, system.length(result) + 1); 204 | result[system.length(result) - 1] := self.substring(lastpos, i - lastpos); 205 | lastpos := i + 1; 206 | break; 207 | end; 208 | end; 209 | end; 210 | setlength(result, system.length(result) + 1); 211 | result[system.length(result) - 1] := self.substring(lastpos); 212 | end; 213 | 214 | { 215 | Function Split(const Separators: array of Char; ACount: Integer): TStringArray; overload; 216 | Function Split(const Separators: array of Char; Options: TStringSplitOptions): TStringArray; overload; 217 | Function Split(const Separators: array of Char; ACount: Integer; Options: TStringSplitOptions): TStringArray; overload; 218 | Function Split(const Separators: array of string): TStringArray; overload; 219 | Function Split(const Separators: array of string; ACount: Integer): TStringArray; overload; 220 | Function Split(const Separators: array of string; Options: TStringSplitOptions): TStringArray; overload; 221 | Function Split(const Separators: array of string; ACount: Integer; Options: TStringSplitOptions): TStringArray; overload; 222 | Function Split(const Separators: array of Char; AQuote: Char): TStringArray; overload; 223 | Function Split(const Separators: array of Char; AQuoteStart, AQuoteEnd: Char): TStringArray; overload; 224 | Function Split(const Separators: array of Char; AQuoteStart, AQuoteEnd: Char; Options: TStringSplitOptions): TStringArray; overload; 225 | Function Split(const Separators: array of Char; AQuoteStart, AQuoteEnd: Char; ACount: Integer): TStringArray; overload; 226 | Function Split(const Separators: array of Char; AQuoteStart, AQuoteEnd: Char; ACount: Integer; Options: TStringSplitOptions): TStringArray; overload; 227 | Function Split(const Separators: array of string; AQuote: Char): TStringArray; overload; 228 | Function Split(const Separators: array of string; AQuoteStart, AQuoteEnd: Char): TStringArray; overload; 229 | Function Split(const Separators: array of string; AQuoteStart, AQuoteEnd: Char; Options: TStringSplitOptions): TStringArray; overload; 230 | Function Split(const Separators: array of string; AQuoteStart, AQuoteEnd: Char; ACount: Integer): TStringArray; overload; 231 | Function Split(const Separators: array of string; AQuoteStart, AQuoteEnd: Char; ACount: Integer; Options: TStringSplitOptions): TStringArray; overload; 232 | } 233 | 234 | { 235 | toUTF8Bytes : returns array of bytes encoded in UTF8. 236 | } 237 | 238 | function TUnicodeStringHelper.toWideCharArray : TWideChars; 239 | begin 240 | setlength(result, self.length); 241 | move(self[1], result[0], sizeof(WideChar)); 242 | end; 243 | 244 | function TUnicodeStringHelper.toWordArray : TWords; 245 | var 246 | len : longint; 247 | begin 248 | len := self.length; 249 | setlength(result, len); 250 | move(self[1], result[0], sizeof(WideChar) * len); 251 | end; 252 | 253 | function TUnicodeStringHelper.toUTF8Bytes : TBytes; 254 | var 255 | cv, i, len, cl : integer; 256 | p : pbyte; 257 | cw : WideChar; 258 | begin 259 | len := self.getUTF8BytesLength; 260 | setlength(Result, len); 261 | p := @Result[0]; 262 | for i := 1 to self.length do 263 | begin 264 | cw := self[i]; 265 | cv := cw.toCharCode; 266 | cl := cw.getUTF8Length; 267 | case cl of 268 | 1: 269 | begin 270 | p^ := cv; 271 | end; 272 | 273 | 2: 274 | begin 275 | p^ := %11000000 or ((cv >> 6) and %00011111); 276 | p += 1; 277 | p^ := %10000000 or (cv and %00111111); 278 | end; 279 | 280 | 3: 281 | begin 282 | p^ := %11100000 or ((cv >> 12) and %00001111); 283 | p += 1; 284 | p^ := %10000000 or ((cv >> 6) and %00111111); 285 | p += 1; 286 | p^ := %10000000 or (cv and %00111111); 287 | end; 288 | 289 | 4: raise exception.create('Characters $10000+ unsupported'); 290 | end; 291 | p += 1; 292 | end; 293 | end; 294 | 295 | { 296 | toUTF16Bytes : returns array of bytes encoded in UTF16. 297 | } 298 | function TUnicodeStringHelper.toUTF16Bytes : TBytes; 299 | var 300 | len : integer; 301 | begin 302 | len := self.getUTF16BytesLength; 303 | setlength(Result, len); 304 | move(self[1], Result[0], len); 305 | end; 306 | 307 | { 308 | toCPBytes : returns array of bytes. if character is beyond the 255 range, it 309 | is converted to NULL. 310 | } 311 | function TUnicodeStringHelper.toCPBytes : TBytes; 312 | var 313 | len, i, cv : integer; 314 | begin 315 | len := self.length; 316 | setlength(Result, len); 317 | for i := 1 to len do 318 | begin 319 | cv := self[i].toCharCode; 320 | if cv > 255 then 321 | cv := 0; 322 | Result[i - 1] := cv; 323 | end; 324 | end; 325 | 326 | { 327 | toEncodedCPBytes : convert unicodestring to 8 bit ascii using mapping table 328 | } 329 | function TUnicodeStringHelper.toEncodedCPBytes(table : PWord) : TBytes; 330 | var 331 | len, i, cv : integer; 332 | ascii, j : integer; 333 | begin 334 | len := self.length; 335 | setlength(Result, len); 336 | for i := 1 to len do 337 | begin 338 | cv := self[i].toCharCode; 339 | 340 | ascii := 0; 341 | // skip control codes 342 | for j := 32 to 255 do 343 | begin 344 | if cv = table[j] then 345 | begin 346 | ascii := j; 347 | break; 348 | end; 349 | end; 350 | Result[i - 1] := ascii; 351 | end; 352 | end; 353 | 354 | { 355 | getUTF8BytesLength : returns number of bytes required to encode as UTF8. 356 | } 357 | function TUnicodeStringHelper.getUTF8BytesLength : integer; 358 | var 359 | i : integer; 360 | begin 361 | result := 0; 362 | for i := 1 to system.length(self) do 363 | result += self[i].getUTF8Length; 364 | end; 365 | 366 | { 367 | getUTF16BytesLength : returns number of bytes required to encode as UTF16. 368 | } 369 | function TUnicodeStringHelper.getUTF16BytesLength : integer; inline; 370 | begin 371 | result := self.length << 1; 372 | end; 373 | 374 | { 375 | getCPBytesLength : returns number of bytes required to encode as codepage. 376 | Does not consider any characters beyond the 255 charcode value. 377 | } 378 | function TUnicodeStringHelper.getCPBytesLength : integer; inline; 379 | begin 380 | result := self.length; 381 | end; 382 | 383 | { 384 | fromUTF8Bytes : returns unicodestring of UTF8 in bytes. ignores broken bytes 385 | of partial codepoints on end. use hasUTF8BrokenBytes / getUTF8BrokenBytes to 386 | detect / retrieve the broken bytes to pump into next chunk from stream. 387 | } 388 | function TUnicodeStringHelper.fromUTF8Bytes(bytes : TBytes) : UnicodeString; 389 | var 390 | len, pos : integer; 391 | val : UInt32; 392 | b : byte; 393 | begin 394 | len := system.length(bytes); 395 | result := ''; 396 | pos := 0; 397 | while pos < len do 398 | begin 399 | b := bytes[pos]; 400 | if (b and %11111000) = %11110000 then 401 | begin 402 | // 4 bytes 403 | raise exception.create('Characters $10000+ unsupported'); 404 | end 405 | else if (b and %11110000) = %11100000 then 406 | begin 407 | // 3 bytes 408 | if pos + 3 <= len then 409 | begin 410 | val := (bytes[pos + 2] and $3F) 411 | or ((bytes[pos + 1] and $3F) << 6) 412 | or ((b and $0F) << 12); 413 | result += WideChar(val); 414 | end; 415 | //else broken 416 | pos += 3; 417 | end 418 | else if (b and %11100000) = %11000000 then 419 | begin 420 | // 2 bytes 421 | if pos + 2 <= len then 422 | begin 423 | val := (bytes[pos + 1] and $3F) 424 | or ((b and $1F) << 6); 425 | result += WideChar(val); 426 | end; 427 | //else broken 428 | pos += 2; 429 | 430 | end 431 | else if (b and %10000000) = %00000000 then 432 | begin 433 | // 1 byte 434 | result += WideChar(b); 435 | pos += 1; 436 | end; 437 | end; 438 | end; 439 | 440 | { 441 | fromUTF16Bytes : returns unicodestring of UTF16 in bytes. ignores broken bytes 442 | of partial codepoints on end. use hasUTF16BrokenBytes / getUTF16BrokenBytes 443 | to detect / retrieve the broken bytes to pump into next chunk from stream. 444 | } 445 | function TUnicodeStringHelper.fromUTF16Bytes(bytes : TBytes) : UnicodeString; 446 | var 447 | len, pos : integer; 448 | begin 449 | len := system.length(bytes); 450 | result := ''; 451 | pos := 0; 452 | while pos < len do 453 | begin 454 | if pos + 1 < len then 455 | result += widechar(bytes[pos] + (bytes[pos + 1] << 8)); // little endian 456 | pos += 2; 457 | end; 458 | end; 459 | 460 | { 461 | fromCPBytes : returns unicodestring of ascii in bytes. 462 | } 463 | function TUnicodeStringHelper.fromCPBytes(bytes : TBytes) : UnicodeString; 464 | var 465 | len, i : integer; 466 | begin 467 | len := system.length(bytes); 468 | result := ''; 469 | for i := 0 to len - 1 do 470 | result += WideChar(bytes[i]); 471 | end; 472 | 473 | { 474 | getUTF8BrokenBytes : returns left overs of broken codepoints in byte array. 475 | } 476 | function TUnicodeStringHelper.getUTF8BrokenBytes(bytes : TBytes) : TBytes; 477 | var 478 | len, pos : integer; 479 | b : byte; 480 | begin 481 | len := system.length(bytes); 482 | pos := 0; 483 | while pos < len do 484 | begin 485 | b := bytes[pos]; 486 | if (b and %11111000) = %11110000 then 487 | begin 488 | // 4 bytes 489 | raise exception.create('Characters $10000+ unsupported'); 490 | end 491 | else if (b and %11110000) = %11100000 then 492 | begin 493 | // 3 bytes 494 | if pos + 3 > len then 495 | begin 496 | setlength(result, len - pos); 497 | move(bytes[pos], result[0], len-pos); 498 | exit; 499 | end; 500 | pos += 3; 501 | end 502 | else if (b and %11100000) = %11000000 then 503 | begin 504 | // 2 bytes 505 | if pos + 2 > len then 506 | begin 507 | setlength(result, len - pos); 508 | move(bytes[pos], result[0], len-pos); 509 | exit; 510 | end; 511 | pos += 2; 512 | end 513 | else if (b and %10000000) = %00000000 then 514 | begin 515 | pos += 1; 516 | end; 517 | end; 518 | setlength(result, 0); 519 | end; 520 | 521 | { 522 | getUTF16BrokenBytes : returns left overs of broken codepoints in byte array. 523 | } 524 | function TUnicodeStringHelper.getUTF16BrokenBytes(bytes : TBytes) : TBytes; 525 | begin 526 | if self.HasUTF16BrokenBytes(bytes) then 527 | begin 528 | setlength(Result, 1); 529 | Result[0] := bytes[system.length(bytes) - 1]; 530 | end 531 | else 532 | setlength(Result, 0); 533 | end; 534 | 535 | { 536 | getCPBrokenBytes : always returns empty byte array. 537 | } 538 | function TUnicodeStringHelper.getCPBrokenBytes(bytes : TBytes) : TBytes; inline; 539 | begin 540 | setlength(Result, 0); 541 | end; 542 | 543 | { 544 | hasUTF8BrokenBytes : returns true if there is a broken codepoint at the end 545 | of the byte array. 546 | } 547 | function TUnicodeStringHelper.hasUTF8BrokenBytes(bytes : TBytes) : boolean; 548 | var 549 | len, pos : integer; 550 | b : byte; 551 | begin 552 | len := system.length(bytes); 553 | pos := 0; 554 | while pos < len do 555 | begin 556 | b := bytes[pos]; 557 | if (b and %11111000) = %11110000 then 558 | begin 559 | // 4 bytes 560 | raise exception.create('Characters $10000+ unsupported'); 561 | end 562 | else if (b and %11110000) = %11100000 then 563 | begin 564 | // 3 bytes 565 | if pos + 3 >= len then 566 | exit(true); 567 | pos += 3; 568 | end 569 | else if (b and %11100000) = %11000000 then 570 | begin 571 | // 2 bytes 572 | if pos + 2 >= len then 573 | exit(true); 574 | pos += 2; 575 | end 576 | else if (b and %10000000) = %00000000 then 577 | begin 578 | pos += 1; 579 | end; 580 | end; 581 | result := false; 582 | end; 583 | 584 | { 585 | hasUTF16BrokenBytes : returns true if there is a broken codepoint at the end 586 | of the byte array. 587 | } 588 | function TUnicodeStringHelper.hasUTF16BrokenBytes(bytes : TBytes) : boolean; inline; 589 | begin 590 | result := ((system.length(bytes) and $1) <> 0); 591 | end; 592 | 593 | { 594 | hasCPBrokenBytes : always returns false. 595 | } 596 | function TUnicodeStringHelper.hasCPBrokenBytes(bytes : TBytes) : boolean; inline; 597 | begin 598 | result := false; 599 | end; 600 | 601 | { 602 | mapCP : will convert a codepaged unicodestring to true unicode using an 603 | array [0..255] of WideChars. if a character is outside the 0-255 range, it 604 | will be mapped to null. 605 | } 606 | procedure TUnicodeStringHelper.mapCP(map : TWideChars); 607 | var 608 | len, i : integer; 609 | pwc : PWideChar; 610 | cpchr : integer; 611 | begin 612 | if system.length(map) <> 256 then 613 | raise exception.create('Invalid mapping table length. Needs 256 characters.'); 614 | 615 | len := self.length; 616 | pwc := getmemory(len * sizeof(WideChar)); 617 | move(self[1], pwc, len * sizeof(WideChar)); 618 | self := ''; 619 | for i := 0 to len - 1 do 620 | begin 621 | cpchr := pwc[i].toCharCode; 622 | if cpchr > 255 then 623 | cpchr := 0; // set to null if out of range. 624 | self += map[cpchr]; 625 | end; 626 | freememory(pwc); 627 | end; 628 | 629 | end. 630 | 631 | -------------------------------------------------------------------------------- /vtxcolordlg.lfm: -------------------------------------------------------------------------------- 1 | object fColorDialog: TfColorDialog 2 | Left = 639 3 | Height = 354 4 | Top = 354 5 | Width = 519 6 | BorderStyle = bsDialog 7 | Caption = 'ANSI Colors' 8 | ClientHeight = 354 9 | ClientWidth = 519 10 | OnCreate = FormCreate 11 | OnDestroy = FormDestroy 12 | OnShow = FormShow 13 | LCLVersion = '1.6.4.0' 14 | object bOK: TButton 15 | Left = 8 16 | Height = 25 17 | Top = 323 18 | Width = 75 19 | Caption = 'OK' 20 | ModalResult = 1 21 | TabOrder = 0 22 | end 23 | object bCancel: TButton 24 | Left = 90 25 | Height = 25 26 | Top = 323 27 | Width = 75 28 | Cancel = True 29 | Caption = 'Cancel' 30 | ModalResult = 2 31 | TabOrder = 1 32 | end 33 | object Label1: TLabel 34 | Left = 6 35 | Height = 15 36 | Top = 6 37 | Width = 64 38 | Caption = 'ANSI colors:' 39 | ParentColor = False 40 | end 41 | object pbColors: TPaintBox 42 | Left = 8 43 | Height = 297 44 | Top = 22 45 | Width = 261 46 | ParentColor = False 47 | OnMouseDown = pbColorsMouseDown 48 | OnPaint = pbColorsPaint 49 | end 50 | object Label2: TLabel 51 | Left = 190 52 | Height = 15 53 | Top = 329 54 | Width = 32 55 | Caption = 'Color:' 56 | ParentColor = False 57 | end 58 | object tbANSIColor: TEdit 59 | Left = 225 60 | Height = 23 61 | Top = 325 62 | Width = 44 63 | NumbersOnly = True 64 | OnEditingDone = tbANSIColorEditingDone 65 | TabOrder = 2 66 | Text = 'tbANSIColor' 67 | end 68 | object pbHS: TPaintBox 69 | Left = 276 70 | Height = 193 71 | Top = 6 72 | Width = 209 73 | OnMouseDown = pbHSMouseDown 74 | OnMouseMove = pbHSMouseMove 75 | OnMouseUp = pbHSMouseUp 76 | OnPaint = pbHSPaint 77 | end 78 | object pbL: TPaintBox 79 | Left = 490 80 | Height = 193 81 | Top = 8 82 | Width = 24 83 | OnMouseDown = pbLMouseDown 84 | OnMouseMove = pbLMouseMove 85 | OnMouseUp = pbLMouseUp 86 | OnPaint = pbLPaint 87 | end 88 | object tbRed: TEdit 89 | Left = 306 90 | Height = 23 91 | Top = 230 92 | Width = 44 93 | NumbersOnly = True 94 | OnEditingDone = tbRedEditingDone 95 | TabOrder = 3 96 | Text = 'tbRed' 97 | end 98 | object Label3: TLabel 99 | Left = 280 100 | Height = 15 101 | Top = 232 102 | Width = 23 103 | Caption = 'Red:' 104 | ParentColor = False 105 | end 106 | object tbHue: TEdit 107 | Left = 306 108 | Height = 23 109 | Top = 256 110 | Width = 44 111 | NumbersOnly = True 112 | OnEditingDone = tbHueEditingDone 113 | TabOrder = 4 114 | Text = 'tbHue' 115 | end 116 | object Label4: TLabel 117 | Left = 278 118 | Height = 15 119 | Top = 258 120 | Width = 25 121 | Caption = 'Hue:' 122 | ParentColor = False 123 | end 124 | object tbL: TEdit 125 | Left = 306 126 | Height = 23 127 | Top = 282 128 | Width = 44 129 | Enabled = False 130 | ReadOnly = True 131 | TabOrder = 5 132 | Text = 'tbL' 133 | end 134 | object Label5: TLabel 135 | Left = 294 136 | Height = 15 137 | Top = 284 138 | Width = 9 139 | Caption = 'L:' 140 | ParentColor = False 141 | end 142 | object tbB: TEdit 143 | Left = 470 144 | Height = 23 145 | Top = 282 146 | Width = 44 147 | Enabled = False 148 | ReadOnly = True 149 | TabOrder = 6 150 | Text = 'tbB' 151 | end 152 | object tbBlue: TEdit 153 | Left = 470 154 | Height = 23 155 | Top = 230 156 | Width = 44 157 | NumbersOnly = True 158 | OnEditingDone = tbBlueEditingDone 159 | TabOrder = 7 160 | Text = 'tbBlue' 161 | end 162 | object tbLum: TEdit 163 | Left = 470 164 | Height = 23 165 | Top = 256 166 | Width = 44 167 | NumbersOnly = True 168 | OnEditingDone = tbLumEditingDone 169 | TabOrder = 8 170 | Text = 'tbLum' 171 | end 172 | object Label6: TLabel 173 | Left = 440 174 | Height = 15 175 | Top = 232 176 | Width = 26 177 | Caption = 'Blue:' 178 | ParentColor = False 179 | end 180 | object Label7: TLabel 181 | Left = 439 182 | Height = 15 183 | Top = 258 184 | Width = 27 185 | Caption = 'Lum:' 186 | ParentColor = False 187 | end 188 | object Label8: TLabel 189 | Left = 456 190 | Height = 15 191 | Top = 284 192 | Width = 10 193 | Caption = 'B:' 194 | ParentColor = False 195 | end 196 | object Label9: TLabel 197 | Left = 354 198 | Height = 15 199 | Top = 232 200 | Width = 34 201 | Caption = 'Green:' 202 | ParentColor = False 203 | end 204 | object Label10: TLabel 205 | Left = 368 206 | Height = 15 207 | Top = 258 208 | Width = 19 209 | Caption = 'Sat:' 210 | ParentColor = False 211 | end 212 | object Label11: TLabel 213 | Left = 376 214 | Height = 15 215 | Top = 284 216 | Width = 11 217 | Caption = 'A:' 218 | ParentColor = False 219 | end 220 | object tbA: TEdit 221 | Left = 390 222 | Height = 23 223 | Top = 282 224 | Width = 44 225 | Enabled = False 226 | ReadOnly = True 227 | TabOrder = 9 228 | Text = 'tbA' 229 | end 230 | object tbSat: TEdit 231 | Left = 390 232 | Height = 23 233 | Top = 256 234 | Width = 44 235 | NumbersOnly = True 236 | OnEditingDone = tbSatEditingDone 237 | TabOrder = 10 238 | Text = 'tbSat' 239 | end 240 | object tbGreen: TEdit 241 | Left = 390 242 | Height = 23 243 | Top = 230 244 | Width = 44 245 | NumbersOnly = True 246 | OnEditingDone = tbGreenEditingDone 247 | TabOrder = 11 248 | Text = 'tbGreen' 249 | end 250 | object pbDesiredColor: TPaintBox 251 | Left = 282 252 | Height = 24 253 | Top = 324 254 | Width = 115 255 | OnPaint = pbDesiredColorPaint 256 | end 257 | object Label12: TLabel 258 | Left = 282 259 | Height = 15 260 | Top = 306 261 | Width = 45 262 | Caption = 'Desided:' 263 | ParentColor = False 264 | end 265 | object Label13: TLabel 266 | Left = 400 267 | Height = 15 268 | Top = 306 269 | Width = 37 270 | Caption = 'Actual:' 271 | ParentColor = False 272 | end 273 | object pbActualColor: TPaintBox 274 | Left = 400 275 | Height = 24 276 | Top = 324 277 | Width = 115 278 | OnPaint = pbActualColorPaint 279 | end 280 | object Label14: TLabel 281 | Left = 280 282 | Height = 15 283 | Top = 208 284 | Width = 23 285 | Caption = 'Hex:' 286 | ParentColor = False 287 | end 288 | object tbHex: TEdit 289 | Left = 306 290 | Height = 23 291 | Top = 204 292 | Width = 208 293 | MaxLength = 7 294 | OnEditingDone = tbHexEditingDone 295 | TabOrder = 12 296 | Text = 'tbHex' 297 | end 298 | end 299 | -------------------------------------------------------------------------------- /vtxcolordlg.lrs: -------------------------------------------------------------------------------- 1 | { This is an automatically generated lazarus resource file } 2 | 3 | LazarusResources.Add('TfColorDialog','FORMDATA',[ 4 | 'TPF0'#13'TfColorDialog'#12'fColorDialog'#4'Left'#3#251#2#6'Height'#3'B'#1#3 5 | +'Top'#3#162#1#5'Width'#3#7#2#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#11'A' 6 | +'NSI Colors'#12'ClientHeight'#3'B'#1#11'ClientWidth'#3#7#2#10'LCLVersion'#6#7 7 | +'1.6.4.0'#0#7'TButton'#7'Button1'#4'Left'#2#8#6'Height'#2#25#3'Top'#3#30#1#5 8 | +'Width'#2'K'#7'Caption'#6#2'OK'#11'ModalResult'#2#1#8'TabOrder'#2#0#0#0#7'TB' 9 | +'utton'#7'Button2'#4'Left'#2'Z'#6'Height'#2#25#3'Top'#3#30#1#5'Width'#2'K'#6 10 | +'Cancel'#9#7'Caption'#6#6'Cancel'#11'ModalResult'#2#2#8'TabOrder'#2#1#0#0#6 11 | +'TLabel'#6'Label1'#4'Left'#2#6#6'Height'#2#15#3'Top'#2#6#5'Width'#2'@'#7'Cap' 12 | +'tion'#6#12'ANSI colors:'#11'ParentColor'#8#0#0#9'TPaintBox'#9'PaintBox1'#4 13 | +'Left'#2#8#6'Height'#3#4#1#3'Top'#2#22#5'Width'#3#5#1#0#0#6'TLabel'#6'Label2' 14 | +#4'Left'#3#174#0#6'Height'#2#15#3'Top'#3'"'#1#5'Width'#2' '#7'Caption'#6#6'C' 15 | +'olor:'#11'ParentColor'#8#0#0#5'TEdit'#5'Edit1'#4'Left'#3#222#0#6'Height'#2 16 | +#23#3'Top'#3#30#1#5'Width'#2','#8'TabOrder'#2#2#4'Text'#6#5'Edit1'#0#0#9'TPa' 17 | +'intBox'#9'PaintBox2'#4'Left'#3#20#1#6'Height'#3#219#0#3'Top'#2#6#5'Width'#3 18 | +#209#0#0#0#9'TPaintBox'#9'PaintBox3'#4'Left'#3#234#1#6'Height'#3#218#0#3'Top' 19 | +#2#6#5'Width'#2#24#0#0#5'TEdit'#5'Edit2'#4'Left'#3'2'#1#6'Height'#2#23#3'Top' 20 | +#3#230#0#5'Width'#2','#8'TabOrder'#2#3#4'Text'#6#5'Edit2'#0#0#6'TLabel'#6'La' 21 | +'bel3'#4'Left'#3#22#1#6'Height'#2#15#3'Top'#3#232#0#5'Width'#2#25#7'Caption' 22 | +#6#4'Hue:'#11'ParentColor'#8#0#0#5'TEdit'#5'Edit3'#4'Left'#3'2'#1#6'Height'#2 23 | +#23#3'Top'#3#0#1#5'Width'#2','#8'TabOrder'#2#4#4'Text'#6#5'Edit3'#0#0#6'TLab' 24 | +'el'#6'Label4'#4'Left'#3#28#1#6'Height'#2#15#3'Top'#3#2#1#5'Width'#2#19#7'Ca' 25 | +'ption'#6#4'Sat:'#11'ParentColor'#8#0#0#5'TEdit'#5'Edit4'#4'Left'#3'2'#1#6'H' 26 | +'eight'#2#23#3'Top'#3#26#1#5'Width'#2','#8'TabOrder'#2#5#4'Text'#6#5'Edit4'#0 27 | +#0#6'TLabel'#6'Label5'#4'Left'#3#20#1#6'Height'#2#15#3'Top'#3#28#1#5'Width'#2 28 | +#27#7'Caption'#6#4'Lum:'#11'ParentColor'#8#0#0#5'TEdit'#5'Edit5'#4'Left'#3 29 | +#214#1#6'Height'#2#23#3'Top'#3#26#1#5'Width'#2','#8'TabOrder'#2#6#4'Text'#6#5 30 | +'Edit5'#0#0#5'TEdit'#5'Edit6'#4'Left'#3#214#1#6'Height'#2#23#3'Top'#3#230#0#5 31 | +'Width'#2','#8'TabOrder'#2#7#4'Text'#6#5'Edit6'#0#0#5'TEdit'#5'Edit7'#4'Left' 32 | +#3#214#1#6'Height'#2#23#3'Top'#3#0#1#5'Width'#2','#8'TabOrder'#2#8#4'Text'#6 33 | +#5'Edit7'#0#0#6'TLabel'#6'Label6'#4'Left'#3#189#1#6'Height'#2#15#3'Top'#3#232 34 | +#0#5'Width'#2#23#7'Caption'#6#4'Red:'#11'ParentColor'#8#0#0#6'TLabel'#6'Labe' 35 | +'l7'#4'Left'#3#178#1#6'Height'#2#15#3'Top'#3#2#1#5'Width'#2'"'#7'Caption'#6#6 36 | +'Green:'#11'ParentColor'#8#0#0#6'TLabel'#6'Label8'#4'Left'#3#186#1#6'Height' 37 | +#2#15#3'Top'#3#28#1#5'Width'#2#26#7'Caption'#6#5'Blue:'#11'ParentColor'#8#0#0 38 | +#6'TLabel'#6'Label9'#4'Left'#3'm'#1#6'Height'#2#15#3'Top'#3#232#0#5'Width'#2 39 | +#9#7'Caption'#6#2'L:'#11'ParentColor'#8#0#0#6'TLabel'#7'Label10'#4'Left'#3'k' 40 | +#1#6'Height'#2#15#3'Top'#3#2#1#5'Width'#2#11#7'Caption'#6#2'A:'#11'ParentCol' 41 | +'or'#8#0#0#6'TLabel'#7'Label11'#4'Left'#3'l'#1#6'Height'#2#15#3'Top'#3#30#1#5 42 | +'Width'#2#10#7'Caption'#6#2'B:'#11'ParentColor'#8#0#0#5'TEdit'#5'Edit8'#4'Le' 43 | +'ft'#3'z'#1#6'Height'#2#23#3'Top'#3#26#1#5'Width'#2','#8'TabOrder'#2#9#4'Tex' 44 | +'t'#6#5'Edit8'#0#0#5'TEdit'#5'Edit9'#4'Left'#3'z'#1#6'Height'#2#23#3'Top'#3#0 45 | +#1#5'Width'#2','#8'TabOrder'#2#10#4'Text'#6#5'Edit9'#0#0#5'TEdit'#6'Edit10'#4 46 | +'Left'#3'z'#1#6'Height'#2#23#3'Top'#3#230#0#5'Width'#2','#8'TabOrder'#2#11#4 47 | +'Text'#6#6'Edit10'#0#0#0 48 | ]); 49 | -------------------------------------------------------------------------------- /vtxcolordlg.pas: -------------------------------------------------------------------------------- 1 | { 2 | 3 | BSD 2-Clause License 4 | 5 | Copyright (c) 2017, Daniel Mecklenburg Jr. All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | } 29 | 30 | unit VTXColorDlg; 31 | 32 | {$mode objfpc}{$H+} 33 | 34 | interface 35 | 36 | uses 37 | Classes, 38 | SysUtils, 39 | LResources, 40 | Forms, 41 | Controls, 42 | Graphics, 43 | Dialogs, 44 | ExtCtrls, 45 | Buttons, 46 | Math, 47 | VTXSupport, 48 | VTXConst, 49 | StdCtrls; 50 | 51 | type 52 | 53 | TLAB = record 54 | l, a, b : double; 55 | end; 56 | 57 | THSL = record 58 | h, s, l : double; 59 | end; 60 | 61 | TRGB = record 62 | r, g, b : double; 63 | end; 64 | 65 | TXYZ = record 66 | x, y, z : double; 67 | end; 68 | 69 | { TfColorDialog } 70 | 71 | TfColorDialog = class(TForm) 72 | bOK: TButton; 73 | bCancel: TButton; 74 | tbANSIColor: TEdit; 75 | tbGreen: TEdit; 76 | tbHex: TEdit; 77 | tbRed: TEdit; 78 | tbHue: TEdit; 79 | tbL: TEdit; 80 | tbB: TEdit; 81 | tbBlue: TEdit; 82 | tbLum: TEdit; 83 | tbA: TEdit; 84 | tbSat: TEdit; 85 | Label1: TLabel; 86 | Label10: TLabel; 87 | Label11: TLabel; 88 | Label12: TLabel; 89 | Label13: TLabel; 90 | Label14: TLabel; 91 | Label2: TLabel; 92 | Label3: TLabel; 93 | Label4: TLabel; 94 | Label5: TLabel; 95 | Label6: TLabel; 96 | Label7: TLabel; 97 | Label8: TLabel; 98 | Label9: TLabel; 99 | pbColors: TPaintBox; 100 | pbHS: TPaintBox; 101 | pbL: TPaintBox; 102 | pbDesiredColor: TPaintBox; 103 | pbActualColor: TPaintBox; 104 | procedure FormCreate(Sender: TObject); 105 | procedure FormDestroy(Sender: TObject); 106 | procedure FormShow(Sender: TObject); 107 | procedure pbActualColorPaint(Sender: TObject); 108 | procedure pbColorsMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 109 | procedure pbColorsPaint(Sender: TObject); 110 | procedure pbDesiredColorPaint(Sender: TObject); 111 | procedure pbHSMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 112 | procedure pbHSMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); 113 | procedure pbHSMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 114 | procedure pbHSPaint(Sender: TObject); 115 | procedure pbLMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 116 | procedure pbLMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); 117 | procedure pbLMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 118 | procedure pbLPaint(Sender: TObject); 119 | function FindANSIColor : integer; 120 | procedure SetANSIColor; 121 | procedure SetHSLColor; 122 | procedure SetRGBColor; 123 | procedure SetLABColor; 124 | procedure tbAEditingDone(Sender: TObject); 125 | procedure tbANSIColorEditingDone(Sender: TObject); 126 | procedure tbBEditingDone(Sender: TObject); 127 | procedure tbBlueEditingDone(Sender: TObject); 128 | procedure tbGreenEditingDone(Sender: TObject); 129 | procedure tbHexEditingDone(Sender: TObject); 130 | procedure tbHueEditingDone(Sender: TObject); 131 | procedure tbLEditingDone(Sender: TObject); 132 | procedure tbLumEditingDone(Sender: TObject); 133 | procedure tbRedEditingDone(Sender: TObject); 134 | procedure tbSatEditingDone(Sender: TObject); 135 | private 136 | { private declarations } 137 | public 138 | { public declarations } 139 | fColor : integer; // ansi color 0-255 140 | fMaxColors : integer; 141 | end; 142 | 143 | var 144 | fColorDialog: TfColorDialog; 145 | bmpHS : TBitmap; 146 | ANSILAB : array [0 .. 255] of TLAB; 147 | 148 | rows : integer; 149 | 150 | // desired color 151 | DesiredRGB : TRGB; 152 | DesiredHSL : THSL; 153 | DesiredXYZ : TXYZ; 154 | DesiredLAB : TLAB; 155 | 156 | drag : boolean; 157 | 158 | const 159 | d65: TXYZ = ( 160 | x: 0.9505; 161 | y: 1.0; 162 | z: 1.0890; 163 | ); 164 | 165 | function RGB2XYZ(rgb: TRGB): TXYZ; 166 | function RGB2HSL(rgb: TRGB): THSL; 167 | function XYZ2LAB(xyz: TXYZ): TLAB; 168 | function HSL2RGB(hsl: THSL): TRGB; 169 | function XYZ2RGB(xyz: TXYZ): TRGB; 170 | function LAB2XYZ(lab: TLAB): TXYZ; 171 | function SetRGB(r, g, b : byte) : TRGB; 172 | function doubletostr(v : double) : string; 173 | function Distance3D(x1, y1, z1, x2, y2, z2 : double): double; 174 | 175 | implementation 176 | 177 | { TfColorDialog } 178 | 179 | function SetRGB(r, g, b : byte) : TRGB; 180 | begin 181 | result.r := r / 255.0; 182 | result.g := g / 255.0; 183 | result.b := b / 255.0; 184 | end; 185 | 186 | // paint color picker + highlight selected color 187 | procedure TfColorDialog.pbColorsPaint(Sender: TObject); 188 | var 189 | pb : TPaintBox; 190 | cnv : TCanvas; 191 | x, y, c : integer; 192 | cw, ch : integer; 193 | r : TRect; 194 | begin 195 | pb := TPaintBox(Sender); 196 | cnv := pb.Canvas; 197 | cw := pb.Width >> 4; 198 | ch := pb.Height >> 4; 199 | 200 | // draw selection rect first 201 | x := fColor and $F; 202 | y := fColor >> 4; 203 | r.Top := y * ch; 204 | r.Left := x * cw; 205 | r.Width := cw + 2; 206 | r.Height := ch + 2; 207 | cnv.Brush.Color := clWhite; 208 | cnv.Pen.Color := clWhite; 209 | cnv.DrawFocusRect(r); 210 | 211 | c := 0; 212 | for y := 0 to rows do 213 | begin 214 | for x := 0 to 15 do 215 | begin 216 | r.Top := y * ch + 2; 217 | r.Left := x * cw + 2; 218 | r.Width := cw - 2; 219 | r.Height := ch - 2; 220 | 221 | cnv.Brush.Color := ANSIColor[c]; 222 | cnv.FillRect(r); 223 | Draw3DRect(cnv, r, true); 224 | c += 1; 225 | end; 226 | end; 227 | end; 228 | 229 | procedure TfColorDialog.pbDesiredColorPaint(Sender: TObject); 230 | var 231 | pb : TPaintBox; 232 | cnv : TCanvas; 233 | r, g, b : integer; 234 | rect : TRect; 235 | begin 236 | pb := TPaintBox(Sender); 237 | cnv := pb.Canvas; 238 | rect := pb.ClientRect; 239 | 240 | r := floor(DesiredRGB.r * 255.0); 241 | g := floor(DesiredRGB.g * 255.0); 242 | b := floor(DesiredRGB.b * 255.0); 243 | 244 | cnv.Brush.Color := RGBToColor(r, g, b); 245 | cnv.FillRect(rect); 246 | Draw3DRect(cnv, rect, true); 247 | end; 248 | 249 | procedure TfColorDialog.pbActualColorPaint(Sender: TObject); 250 | var 251 | pb : TPaintBox; 252 | cnv : TCanvas; 253 | r, g, b : integer; 254 | rect : TRect; 255 | begin 256 | pb := TPaintBox(Sender); 257 | cnv := pb.Canvas; 258 | rect := pb.ClientRect; 259 | 260 | r := (ANSIColor[fColor] ) and $FF; 261 | g := (ANSIColor[fColor] >> 8) and $FF; 262 | b := (ANSIColor[fColor] >> 16) and $FF; 263 | 264 | cnv.Brush.Color := RGBToColor(r, g, b); 265 | cnv.FillRect(rect); 266 | Draw3DRect(cnv, rect, true); 267 | end; 268 | 269 | function Distance3D(x1, y1, z1, x2, y2, z2 : double): double; 270 | var 271 | x, y, z : double; 272 | begin 273 | x := (x1 - x2); 274 | y := (y1 - y2); 275 | z := (z1 - z2); 276 | x *= x; 277 | y *= y; 278 | z *= z; 279 | result := (x + y + z); 280 | end; 281 | 282 | // find closest ansi color 283 | function TfColorDialog.FindANSIColor : integer; 284 | var 285 | i : integer; 286 | d, mind : double; 287 | begin 288 | mind := 9999; 289 | for i := 0 to fMaxColors - 1 do 290 | begin 291 | d := Distance3D( 292 | DesiredLAB.l, DesiredLAB.a, DesiredLAB.b, 293 | ANSILAB[i].l, ANSILAB[i].a, ANSILAB[i].b); 294 | if d < mind then 295 | begin 296 | mind := d; 297 | result := i; 298 | end; 299 | end; 300 | end; 301 | 302 | // set all colors based on fcolor 303 | procedure TfColorDialog.SetANSIColor; 304 | var 305 | r, g, b : integer; 306 | begin 307 | // load settings based on fANSIColor. 308 | r := (ANSIColor[fColor] ) and $FF; 309 | g := (ANSIColor[fColor] >> 8) and $FF; 310 | b := (ANSIColor[fColor] >> 16) and $FF; 311 | 312 | DesiredRGB := SetRGB(r, g, b); 313 | DesiredHSL := RGB2HSL(DesiredRGB); 314 | DesiredXYZ := RGB2XYZ(DesiredRGB); 315 | DesiredLAB := XYZ2LAB(DesiredXYZ); 316 | 317 | tbANSIColor.Text := inttostr(fColor); 318 | tbHex.Text := Format('#%2.2X%2.2X%2.2X', [r, g, b]); 319 | 320 | tbRed.Text := inttostr(r); 321 | tbGreen.Text := inttostr(g); 322 | tbBlue.Text := inttostr(b); 323 | 324 | tbHue.Text := doubletostr(DesiredHSL.h * 100); 325 | tbSat.Text := doubletostr(DesiredHSL.s * 100); 326 | tbLum.Text := doubletostr(DesiredHSL.l * 100); 327 | 328 | tbL.Text := doubletostr(DesiredLAB.l); 329 | tbA.Text := doubletostr(DesiredLAB.a); 330 | tbB.Text := doubletostr(DesiredLAB.b); 331 | 332 | pbDesiredColor.Invalidate; 333 | pbActualColor.Invalidate; 334 | pbHS.Invalidate; 335 | pbL.Invalidate; 336 | end; 337 | 338 | procedure TfColorDialog.SetRGBColor; 339 | var 340 | r, g, b : integer; 341 | begin 342 | DesiredHSL := RGB2HSL(DesiredRGB); 343 | DesiredXYZ := RGB2XYZ(DesiredRGB); 344 | DesiredLAB := XYZ2LAB(DesiredXYZ); 345 | 346 | // find closest ANSI color 347 | fColor := FindANSIColor; 348 | 349 | // fill in values 350 | tbANSIColor.Text := inttostr(fColor); 351 | 352 | r := floor(DesiredRGB.r * 255.0); 353 | g := floor(DesiredRGB.g * 255.0); 354 | b := floor(DesiredRGB.b * 255.0); 355 | tbHex.Text := Format('#%2.2X%2.2X%2.2X', [r, g, b]); 356 | 357 | tbRed.Text := inttostr(r); 358 | tbGreen.Text := inttostr(g); 359 | tbBlue.Text := inttostr(b); 360 | 361 | tbHue.Text := doubletostr(DesiredHSL.h * 100); 362 | tbSat.Text := doubletostr(DesiredHSL.s * 100); 363 | tbLum.Text := doubletostr(DesiredHSL.l * 100); 364 | 365 | tbL.Text := doubletostr(DesiredLAB.l); 366 | tbA.Text := doubletostr(DesiredLAB.a); 367 | tbB.Text := doubletostr(DesiredLAB.b); 368 | 369 | pbColors.Invalidate; 370 | pbDesiredColor.Invalidate; 371 | pbActualColor.Invalidate; 372 | pbHS.Invalidate; 373 | pbL.Invalidate; 374 | end; 375 | 376 | procedure TfColorDialog.SetLABColor; 377 | var 378 | r, g, b : integer; 379 | begin 380 | DesiredXYZ := LAB2XYZ(DesiredLAB); 381 | DesiredRGB := XYZ2RGB(DesiredXYZ); 382 | DesiredHSL := RGB2HSL(DesiredRGB); 383 | 384 | // find closest ANSI color 385 | fColor := FindANSIColor; 386 | 387 | // fill in values 388 | tbANSIColor.Text := inttostr(fColor); 389 | 390 | r := floor(DesiredRGB.r * 255.0); 391 | g := floor(DesiredRGB.g * 255.0); 392 | b := floor(DesiredRGB.b * 255.0); 393 | tbHex.Text := Format('#%2.2X%2.2X%2.2X', [r, g, b]); 394 | 395 | tbRed.Text := inttostr(r); 396 | tbGreen.Text := inttostr(g); 397 | tbBlue.Text := inttostr(b); 398 | 399 | tbHue.Text := doubletostr(DesiredHSL.h * 100); 400 | tbSat.Text := doubletostr(DesiredHSL.s * 100); 401 | tbLum.Text := doubletostr(DesiredHSL.l * 100); 402 | 403 | tbL.Text := doubletostr(DesiredLAB.l); 404 | tbA.Text := doubletostr(DesiredLAB.a); 405 | tbB.Text := doubletostr(DesiredLAB.b); 406 | 407 | pbColors.Invalidate; 408 | pbDesiredColor.Invalidate; 409 | pbActualColor.Invalidate; 410 | pbHS.Invalidate; 411 | pbL.Invalidate; 412 | end; 413 | 414 | // set all colors based on desiredhsl 415 | procedure TfColorDialog.SetHSLColor; 416 | var 417 | r, g, b : integer; 418 | begin 419 | DesiredRGB := HSL2RGB(DesiredHSL); 420 | DesiredXYZ := RGB2XYZ(DesiredRGB); 421 | DesiredLAB := XYZ2LAB(DesiredXYZ); 422 | 423 | // find closest ANSI color 424 | fColor := FindANSIColor; 425 | 426 | // fill in values 427 | tbANSIColor.Text := inttostr(fColor); 428 | 429 | r := floor(DesiredRGB.r * 255.0); 430 | g := floor(DesiredRGB.g * 255.0); 431 | b := floor(DesiredRGB.b * 255.0); 432 | tbHex.Text := Format('#%2.2X%2.2X%2.2X', [r, g, b]); 433 | 434 | tbRed.Text := inttostr(r); 435 | tbGreen.Text := inttostr(g); 436 | tbBlue.Text := inttostr(b); 437 | 438 | tbHue.Text := doubletostr(DesiredHSL.h * 100); 439 | tbSat.Text := doubletostr(DesiredHSL.s * 100); 440 | tbLum.Text := doubletostr(DesiredHSL.l * 100); 441 | 442 | tbL.Text := doubletostr(DesiredLAB.l); 443 | tbA.Text := doubletostr(DesiredLAB.a); 444 | tbB.Text := doubletostr(DesiredLAB.b); 445 | 446 | pbColors.Invalidate; 447 | pbDesiredColor.Invalidate; 448 | pbActualColor.Invalidate; 449 | pbHS.Invalidate; 450 | pbL.Invalidate; 451 | end; 452 | 453 | procedure TfColorDialog.tbANSIColorEditingDone(Sender: TObject); 454 | var 455 | v : integer; 456 | begin 457 | v := StrToInt(tbANSIColor.Text); 458 | if v < 0 then 459 | v := 0; 460 | if v > fMaxColors - 1 then 461 | v := fMaxColors - 1; 462 | fColor := v; 463 | SetANSIColor; 464 | pbColors.Invalidate; 465 | end; 466 | 467 | function HexChar(ch : char) : integer; 468 | var 469 | c : integer; 470 | begin 471 | ch := UpCase(ch); 472 | result := string('0123456789ABCDEF').IndexOf(ch); 473 | end; 474 | 475 | procedure TfColorDialog.tbHexEditingDone(Sender: TObject); 476 | var 477 | hex : string; 478 | i : integer; 479 | v : longint; 480 | r, g, b : integer; 481 | begin 482 | // validate hex 483 | hex := tbHex.Text; 484 | if (hex.Length = 7) and (LeftStr(hex,1) = '#') then 485 | hex := RightStr(hex, 6); 486 | if hex.Length = 6 then 487 | begin 488 | for i := 0 to 5 do 489 | if HexChar(hex.Chars[i]) = -1 then 490 | exit; 491 | v := StrToInt('$' + hex); 492 | r := (v >> 16) and $FF; 493 | g := (v >> 8) and $FF; 494 | b := (v ) and $FF; 495 | DesiredRGB := SetRGB(r, g, b); 496 | SetRGBColor; 497 | end; 498 | end; 499 | 500 | procedure TfColorDialog.tbRedEditingDone(Sender: TObject); 501 | var 502 | v : double; 503 | begin 504 | v := StrToFloat(tbRed.Text) / 255; 505 | if v < 0 then v := 0; 506 | if v > 1 then v := 1; 507 | DesiredRGB.r := v; 508 | SetRGBColor; 509 | end; 510 | 511 | procedure TfColorDialog.tbGreenEditingDone(Sender: TObject); 512 | var 513 | v : double; 514 | begin 515 | v := StrToFloat(tbGreen.Text) / 255; 516 | if v < 0 then v := 0; 517 | if v > 1 then v := 1; 518 | DesiredRGB.g := v; 519 | SetRGBColor; 520 | end; 521 | 522 | procedure TfColorDialog.tbBlueEditingDone(Sender: TObject); 523 | var 524 | v : double; 525 | begin 526 | v := StrToFloat(tbBlue.Text) / 255; 527 | if v < 0 then v := 0; 528 | if v > 1 then v := 1; 529 | DesiredRGB.b := v; 530 | SetRGBColor; 531 | end; 532 | 533 | procedure TfColorDialog.tbHueEditingDone(Sender: TObject); 534 | var 535 | v : double; 536 | begin 537 | v := StrToFloat(tbHue.Text) / 100; 538 | if v < 0 then v := 0; 539 | if v > 1 then v := 1; 540 | DesiredHSL.h := v; 541 | SetHSLColor; 542 | end; 543 | 544 | procedure TfColorDialog.tbSatEditingDone(Sender: TObject); 545 | var 546 | v : double; 547 | begin 548 | v := StrToFloat(tbSat.Text) / 100; 549 | if v < 0 then v := 0; 550 | if v > 1 then v := 1; 551 | DesiredHSL.s := v; 552 | SetHSLColor; 553 | end; 554 | 555 | procedure TfColorDialog.tbLumEditingDone(Sender: TObject); 556 | var 557 | v : double; 558 | begin 559 | v := StrToFloat(tbLum.Text) / 100; 560 | if v < 0 then v := 0; 561 | if v > 1 then v := 1; 562 | DesiredHSL.l := v; 563 | SetHSLColor; 564 | end; 565 | 566 | procedure TfColorDialog.tbLEditingDone(Sender: TObject); 567 | var 568 | v : double; 569 | begin 570 | v := StrToFloat(tbL.Text); 571 | if v < 0 then v := 0; 572 | if v > 100 then v := 100; 573 | DesiredLAB.l := v; 574 | SetLABColor; 575 | end; 576 | 577 | procedure TfColorDialog.tbAEditingDone(Sender: TObject); 578 | var 579 | v : double; 580 | begin 581 | v := StrToFloat(tbA.Text); 582 | if v < -100 then v := -100; 583 | if v > 100 then v := 100; 584 | DesiredLAB.a := v; 585 | SetLABColor; 586 | end; 587 | 588 | procedure TfColorDialog.tbBEditingDone(Sender: TObject); 589 | begin 590 | DesiredLAB.b := StrToFloat(tbB.Text); 591 | SetLABColor; 592 | end; 593 | 594 | 595 | procedure TfColorDialog.pbHSMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 596 | var 597 | pb : TPaintBox; 598 | w, h : integer; 599 | begin 600 | // pick this color. mark as moving 601 | drag := true; 602 | 603 | pb := TPaintBox(Sender); 604 | w := pb.ClientRect.Width; 605 | h := pb.ClientRect.Height; 606 | 607 | // get hs 608 | DesiredHSL.h := x / w; 609 | DesiredHSL.s := y / h; 610 | SetHSLColor; 611 | end; 612 | 613 | procedure TfColorDialog.pbHSMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); 614 | var 615 | pb : TPaintBox; 616 | w, h : integer; 617 | begin 618 | // pick this color. mark as moving 619 | pb := TPaintBox(Sender); 620 | w := pb.ClientRect.Width; 621 | h := pb.ClientRect.Height; 622 | 623 | if drag and between(X, 0, w - 1) and between(Y, 0, h - 1) then 624 | begin 625 | // get hs 626 | DesiredHSL.h := x / w; 627 | DesiredHSL.s := y / h; 628 | SetHSLColor; 629 | end; 630 | end; 631 | 632 | procedure TfColorDialog.pbHSMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 633 | begin 634 | // pick this color. mark as moving 635 | drag := false; 636 | end; 637 | 638 | procedure TfColorDialog.pbHSPaint(Sender: TObject); 639 | var 640 | pb : TPaintBox; 641 | cnv : TCanvas; 642 | w, h : integer; 643 | x, y : integer; 644 | rect : TRect; 645 | begin 646 | pb := TPaintBox(Sender); 647 | cnv := pb.Canvas; 648 | w := pb.ClientRect.Width; 649 | h := pb.ClientRect.Height; 650 | 651 | cnv.Draw(0, 0, bmpHS); 652 | Draw3DRect(cnv, pb.ClientRect, true); 653 | 654 | x := floor((StrToFloat(tbHue.Text) / 100.0) * w); 655 | y := floor((StrToFloat(tbSat.Text) / 100.0) * h); 656 | rect.Top := y - 1; 657 | rect.Left := x - 1; 658 | rect.Width := 3; 659 | rect.Height := 3; 660 | cnv.Brush.Style := bsClear; 661 | cnv.Pen.Color := clWhite; 662 | cnv.Rectangle(rect); 663 | rect.inflate(1, 1); 664 | cnv.Pen.Color := clBlack; 665 | cnv.Rectangle(rect); 666 | end; 667 | 668 | procedure TfColorDialog.pbLMouseDown(Sender: TObject; Button: TMouseButton; 669 | Shift: TShiftState; X, Y: Integer); 670 | var 671 | pb : TPaintBox; 672 | h : integer; 673 | begin 674 | // pick this color. mark as moving 675 | drag := true; 676 | 677 | pb := TPaintBox(Sender); 678 | h := pb.ClientRect.Height; 679 | 680 | // get hs 681 | DesiredHSL.l := y / h; 682 | 683 | SetHSLColor; 684 | end; 685 | 686 | procedure TfColorDialog.pbLMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); 687 | var 688 | pb : TPaintBox; 689 | w, h : integer; 690 | begin 691 | pb := TPaintBox(Sender); 692 | w := pb.ClientRect.Width; 693 | h := pb.ClientRect.Height; 694 | 695 | if drag and between(X, 0, w - 1) and between(Y, 0, h - 1) then 696 | begin 697 | // get hs 698 | DesiredHSL.l := y / h; 699 | 700 | SetHSLColor; 701 | end; 702 | end; 703 | 704 | procedure TfColorDialog.pbLMouseUp(Sender: TObject; Button: TMouseButton; 705 | Shift: TShiftState; X, Y: Integer); 706 | begin 707 | drag := false; 708 | end; 709 | 710 | procedure TfColorDialog.pbLPaint(Sender: TObject); 711 | var 712 | w, h : integer; 713 | pb : TPaintBox; 714 | cnv : TCanvas; 715 | y : integer; 716 | hsl : THSL; 717 | rgb : TRGB; 718 | r, g, b : byte; 719 | rect : TRect; 720 | begin 721 | // need to draw this custom every time 722 | pb := TPaintBox(Sender); 723 | cnv := pb.Canvas; 724 | w := pb.ClientRect.Width; 725 | h := pb.ClientRect.Height; 726 | 727 | hsl.h := (StrToFloat(tbHue.Text) / 100); 728 | hsl.s := (StrToFloat(tbSat.Text) / 100); 729 | for y := 0 to h - 1 do 730 | begin 731 | hsl.l := y / h; 732 | rgb := HSL2RGB(hsl); 733 | r := floor(rgb.r * 255.0); 734 | g := floor(rgb.g * 255.0); 735 | b := floor(rgb.b * 255.0); 736 | cnv.Pen.Mode := pmCopy; 737 | cnv.Pen.Width := 1; 738 | cnv.Pen.Color := RGBToColor(r, g, b); 739 | cnv.Line(0, y, w - 1, y); 740 | end; 741 | Draw3DRect(cnv, pb.ClientRect, true); 742 | 743 | y := floor((StrToFloat(tbLum.Text) / 100.0) * h); 744 | rect.Top := y - 1; 745 | rect.Left := 0; 746 | rect.Height := 3; 747 | rect.Width := w; 748 | 749 | cnv.Brush.Style := bsClear; 750 | cnv.Pen.Color := clWhite; 751 | cnv.Pen.Mode:= pmXor; 752 | cnv.Rectangle(rect); 753 | end; 754 | 755 | { CONVERT RGB TO XYZ } 756 | function RGB2XYZ(rgb: TRGB): TXYZ; 757 | var 758 | r, g, b: double; 759 | xyz: TXYZ; 760 | 761 | {------------------------------------------------------------------------------ 762 | CONVERSION FOR RGB TO XYZ 763 | } 764 | function _F2S(v: real): real; inline; 765 | var 766 | ret : double; 767 | begin 768 | if v > 0.04045 then 769 | ret := power((v + 0.055) / 1.055, 2.2) 770 | else 771 | ret := v / 12.92; 772 | _F2S := ret; 773 | end; 774 | 775 | begin 776 | r := _F2S(rgb.r); 777 | g := _F2S(rgb.g); 778 | b := _F2S(rgb.b); 779 | xyz.x := (r * 0.4124 + g * 0.3576 + b * 0.1805); 780 | xyz.y := (r * 0.2126 + g * 0.7152 + b * 0.0722); 781 | xyz.z := (r * 0.0193 + g * 0.1192 + b * 0.9505); 782 | RGB2XYZ := xyz; 783 | end; 784 | 785 | { CONVERT RGB TO HSL } 786 | function RGB2HSL(rgb: TRGB): THSL; 787 | var 788 | mx, mn, delta: double; 789 | begin 790 | mx := Max(rgb.r, Max(rgb.g, rgb.b)); 791 | mn := Min(rgb.r, Min(rgb.g, rgb.b)); 792 | result.l := (mx + mn) / 2.0; 793 | 794 | if mx = mn then 795 | begin 796 | result.h := 0; 797 | result.s := 0; 798 | end 799 | else 800 | begin 801 | delta := mx - mn; 802 | if result.l > 0.5 then 803 | result.s := delta / (2 - mx - mn) 804 | else 805 | result.s := delta / (mx + mn); 806 | if rgb.r = mx then 807 | begin 808 | result.h := (rgb.g - rgb.b) / delta; 809 | if rgb.g < rgb.b then 810 | result.h := result.h + 6.0; 811 | end 812 | else 813 | if rgb.g = mx then 814 | result.h := (rgb.b - rgb.r) / delta + 2 815 | else 816 | result.h := (rgb.r - rgb.g) / delta + 4; 817 | end; 818 | if result.s = 0.0 then 819 | result.h := 0.0 820 | else 821 | begin 822 | result.h := result.h / 6.0; 823 | result.h := result.h - floor(result.h); 824 | end; 825 | end; 826 | 827 | { CONVERT XYZ TO LAB } 828 | function XYZ2LAB(xyz: TXYZ): TLAB; 829 | 830 | {------------------------------------------------------------------------------ 831 | CONVERSION FOR XYZ TO LAB 832 | } 833 | function _FXYZ(t: real): real; inline; 834 | var 835 | ret: real; 836 | begin 837 | if t > 0.008856 then 838 | ret := power(t, 1.0 / 3.0) 839 | else 840 | ret := 7.787 * t + (16.0 / 116.0); 841 | _FXYZ := ret; 842 | end; 843 | 844 | begin 845 | result.l := 116.0 * _FXYZ(xyz.y / d65.y) - 16.0; 846 | result.a := 500.0 * (_FXYZ(xyz.x / d65.x) - _FXYZ(xyz.y / d65.y)); 847 | result.b := 200.0 * (_FXYZ(xyz.y / d65.y) - _FXYZ(xyz.z / d65.z)); 848 | end; 849 | 850 | { CONVERT HSL TO RGB } 851 | function HSL2RGB(hsl: THSL): TRGB; 852 | var 853 | q, p: real; 854 | 855 | {------------------------------------------------------------------------------ 856 | CONVERSION FOR HSL TO RGB 857 | } 858 | function _FHSL(p, q, t: real): real; inline; 859 | begin 860 | result := p; 861 | if t < 0.0 then 862 | t := t + 1.0; 863 | 864 | if t > 1.0 then 865 | t := t - 1.0; 866 | 867 | if t * 6 < 1 then 868 | result := p + (q - p) * 6.0 * t 869 | else if t * 2 < 1 then 870 | result := q 871 | else if t * 3 < 2 then 872 | result := p + (q - p) * (2 / 3 - t) * 6; 873 | end; 874 | 875 | begin 876 | if hsl.s = 0 then 877 | begin 878 | result.r := hsl.l; 879 | result.g := hsl.l; 880 | result.b := hsl.l; 881 | end 882 | else 883 | begin 884 | if hsl.l < 0.5 then 885 | q := hsl.l * (1 + hsl.s) 886 | else 887 | q := (hsl.l + hsl.s) - (hsl.l * hsl.s); 888 | p := 2.0 * hsl.l - q; 889 | result.r := _FHSL(p, q, hsl.h + 1 / 3); 890 | result.g := _FHSL(p, q, hsl.h); 891 | result.b := _FHSL(p, q, hsl.h - 1 / 3); 892 | end; 893 | end; 894 | 895 | { CONVERT XYZ to RGB } 896 | function XYZ2RGB(xyz: TXYZ): TRGB; 897 | var 898 | r, g, b: double; 899 | 900 | {------------------------------------------------------------------------------ 901 | CONVERSION FOR XYZ TO RGB 902 | } 903 | function _FFROMS(v: real): real; inline; 904 | begin 905 | if v <= 0.0031308 then 906 | result := 12.92 * v 907 | else 908 | result := (1.055 * power(v, 0.416667)) - 0.055; 909 | end; 910 | 911 | begin 912 | r := xyz.x * 3.2410 - xyz.y * 1.5374 - xyz.z * 0.4986; 913 | g := -xyz.x * 0.9692 + xyz.y * 1.8760 + xyz.z * 0.0416; 914 | b := xyz.x * 0.0556 - xyz.y * 0.2040 + xyz.z * 1.0570; 915 | result.r := _FFROMS(r); 916 | result.g := _FFROMS(g); 917 | result.b := _FFROMS(b); 918 | end; 919 | 920 | { CONVERT LAB TO XYZ } 921 | function LAB2XYZ(lab: TLAB): TXYZ; 922 | var 923 | fx, fy, fz: double; 924 | 925 | {------------------------------------------------------------------------------ 926 | CONVERSION FOR LAB TO XYZ 927 | } 928 | function _FLABADJ(v, w: real): real; inline; 929 | const 930 | delta: double = 6.0 / 29.0; 931 | var 932 | ret: double; 933 | begin 934 | if v > delta then 935 | result := w * (v * v * v) 936 | else 937 | result := (v - 16.0 / 116.0) * 3 * (delta * delta) * w; 938 | end; 939 | 940 | begin 941 | fy := (lab.l + 16.0) / 116.0; 942 | fx := fy + (lab.a / 500.0); 943 | fz := fy - (lab.b / 200.0); 944 | result.x := _FLABADJ(fx, d65.x); 945 | result.y := _FLABADJ(fy, d65.y); 946 | result.z := _FLABADJ(fz, d65.z); 947 | end; 948 | 949 | function doubletostr(v : double) : string; 950 | begin 951 | result := Format('%.2f', [ v ]); 952 | end; 953 | 954 | procedure TfColorDialog.FormCreate(Sender: TObject); 955 | var 956 | w, h : integer; 957 | x, y : integer; 958 | r, g, b : integer; 959 | i : integer; 960 | hsl : THSL; 961 | rgb : TRGB; 962 | xyz : TXYZ; 963 | begin 964 | w := pbHS.Width; 965 | h := pbHS.Height; 966 | 967 | SetANSIColor; 968 | bmpHS := TBitmap.Create; 969 | bmpHS.Width := w; 970 | bmpHS.Height := h; 971 | bmpHS.PixelFormat := pf24bit; 972 | for y := 0 to h - 1 do 973 | for x := 0 to w - 1 do 974 | begin 975 | hsl.h := x / w; 976 | hsl.s := y / h; 977 | hsl.l := 0.5; 978 | rgb := HSL2RGB(hsl); 979 | r := floor(rgb.r * 255); 980 | g := floor(rgb.g * 255); 981 | b := floor(rgb.b * 255); 982 | bmpHS.Canvas.Pixels[x, y] := RGBToColor(r, g, b); 983 | end; 984 | 985 | // ansi lab lut 986 | for i := 0 to 255 do 987 | begin 988 | r := (ANSIColor[i] ) and $FF; 989 | g := (ANSIColor[i] >> 8) and $FF; 990 | b := (ANSIColor[i] >> 16) and $FF; 991 | rgb := SetRGB(r, g, b); 992 | xyz := RGB2XYZ(rgb); 993 | ANSILAB[i] := XYZ2LAB(xyz); 994 | end; 995 | 996 | end; 997 | 998 | procedure TfColorDialog.FormDestroy(Sender: TObject); 999 | begin 1000 | bmpHS.Free; 1001 | end; 1002 | 1003 | procedure TfColorDialog.FormShow(Sender: TObject); 1004 | begin 1005 | // number of rows to display for colors 1006 | rows := iif(fMaxColors = 256, 15, 0); 1007 | if fColor > fMaxColors then 1008 | fColor := fMaxColors - 1; 1009 | end; 1010 | 1011 | procedure TfColorDialog.pbColorsMouseDown(Sender: TObject; 1012 | Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 1013 | var 1014 | pb : TPaintBox; 1015 | x1, y1 : integer; 1016 | cw, ch : integer; 1017 | c : integer; 1018 | begin 1019 | pb := TPaintBox(Sender); 1020 | cw := pb.Width >> 4; 1021 | ch := pb.Height >> 4; 1022 | x1 := x div cw; 1023 | y1 := y div ch; 1024 | if between(x1, 0, 15) and between(y1, 0, rows) then 1025 | begin 1026 | c := x1 + (y1 << 4); 1027 | if between(c, 0, fMaxColors - 1) then 1028 | begin 1029 | fColor := c; 1030 | SetANSIColor; 1031 | pbColors.Invalidate; 1032 | end; 1033 | end; 1034 | end; 1035 | 1036 | initialization 1037 | {$R *.lfm} 1038 | 1039 | end. 1040 | 1041 | -------------------------------------------------------------------------------- /vtxedit.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/vtxedit.ico -------------------------------------------------------------------------------- /vtxedit.ini: -------------------------------------------------------------------------------- 1 | [VTXEdit] 2 | PreviewBoxOpen=1 3 | WindowMax=1 4 | Window=0,0 1046,689 5 | PreviewBox=1340,231 168,363 6 | 7 | [KeyBinds] 8 | Up=CursorUp 9 | Down=CursorDown 10 | Left=CursorLeft 11 | Right=CursorRight 12 | Ctrl+Up=NextFG 13 | Ctrl+Down=PrevFG 14 | Ctrl+Left=PrevBG 15 | Ctrl+Right=NextBG 16 | Return=CursorNewLine 17 | Tab=CursorForwardTab 18 | Shift+Tab=CursorBackwardTab 19 | Back=CursorBack 20 | F1=Print @FKey1@ 21 | F2=Print @FKey2@ 22 | F3=Print @FKey3@ 23 | F4=Print @FKey4@ 24 | F5=Print @FKey5@ 25 | F6=Print @FKey6@ 26 | F7=Print @FKey7@ 27 | F8=Print @FKey8@ 28 | F9=Print @FKey9@ 29 | F10=Print @FKey10@ 30 | Alt+F1=FKeySet 1 31 | Alt+F2=FKeySet 2 32 | Alt+F3=FKeySet 3 33 | Alt+F4=FKeySet 4 34 | Alt+F5=FKeySet 5 35 | Alt+F6=FKeySet 6 36 | Alt+F7=FKeySet 7 37 | Alt+F8=FKeySet 8 38 | Alt+F9=FKeySet 9 39 | Alt+F10=FKeySet 10 40 | Alt+1=ModeChars 41 | Alt+2=ModeLeftRightBlocks 42 | Alt+3=ModeTopBottomBlocks 43 | Alt+4=ModeQuarterBlocks 44 | Alt+5=ModeSixels 45 | ALT+S=ToolSelect 46 | Alt+D=ToolDraw 47 | Alt+P=ToolPaint 48 | Alt+F=ToolFill 49 | Alt+L=ToolLine 50 | Alt+R=ToolRectangle 51 | Alt+E=ToolEllipse 52 | Alt+Y=ToolEyeDropper 53 | Alt+Space=Print \xA0 54 | Ctrl+Space=Print @CurrChar@ 55 | Ctrl+N=FileNew 56 | Ctrl+O=FileOpen 57 | Ctrl+S=FileSave 58 | Ctrl+Q=FileExit 59 | ; <key>=FileSaveAs 60 | ; <key>=FileImport 61 | ; <key>=FileExport 62 | ; <key>=ShowPreview 63 | Ctrl+X=EditCut 64 | Ctrl+C=EditCopy 65 | Ctrl+V=EditPaste 66 | Ctrl+Z=EditUndo 67 | Shift+Ctrl+Z=EditRedo 68 | Ctrl+PgUp=ObjectMoveForward 69 | Ctrl+PgDn=ObjectMoveBack 70 | Shift+PgUp=ObjectMoveToFront 71 | Shift+PgDn=ObjectMoveToBack 72 | Shift+Down=ObjectMerge 73 | Ctrl+Shift+Down=ObjectMergeAll 74 | Ctrl+Tab=ObjectNext 75 | ; <key>=ObjectFlipHorz 76 | ; <key>=ObjectFlipVert 77 | ; <key>=ObjectPrev 78 | ; 79 | Del=Delete 80 | Esc=Escape 81 | -------------------------------------------------------------------------------- /vtxencdetect.pas: -------------------------------------------------------------------------------- 1 | { 2 | 3 | BSD 2-Clause License 4 | 5 | Copyright (c) 2017, Daniel Mecklenburg Jr. All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | } 29 | 30 | unit VTXEncDetect; 31 | 32 | {$mode objfpc}{$H+} 33 | 34 | interface 35 | 36 | uses 37 | Classes, SysUtils; 38 | 39 | type 40 | TDetectEnc = ( 41 | deNone, deAnsi, deAscii, deUtf8Bom, deUtf8NoBom, 42 | deUtf16LeBom, deUtf16LeNoBom, deUtf16BeBom, deUtf16BeNoBom ); 43 | 44 | 45 | function DetectEncoding(buffer : TBytes) : TDetectEnc; 46 | function CheckBom(buffer : TBytes) : TDetectEnc; 47 | 48 | 49 | implementation 50 | 51 | const 52 | _utf16BeBom : array [0..1] of byte = ( $FE, $FF ); 53 | _utf16LeBom : array [0..1] of byte = ( $FF, $FE ); 54 | _utf8Bom : array [0..2] of byte = ( $EF, $BB, $BF ); 55 | 56 | var 57 | _nullSuggestsBinary : boolean = true; 58 | _utf16ExpectedNullPercent : double = 70; 59 | _utf16UnexpectedNullPercent : double = 10; 60 | 61 | function GetBomLengthFromEncodingMode(encoding : TDetectEnc) : integer; 62 | begin 63 | case encoding of 64 | deUtf16BeBom, 65 | deUtf16LeBom: 66 | result := 2; 67 | 68 | deUtf8Bom: 69 | result := 3; 70 | 71 | else 72 | result := 0; 73 | end; 74 | end; 75 | 76 | function CheckBom(buffer : TBytes) : TDetectEnc; 77 | var 78 | size : longint; 79 | begin 80 | size := length(buffer); 81 | result := deNone; 82 | if (size >= 2) 83 | and (buffer[0] = _utf16LeBom[0]) 84 | and (buffer[1] = _utf16LeBom[1]) then 85 | result := deUtf16LeBom; 86 | if (size >= 2) 87 | and (buffer[0] = _utf16BeBom[0]) 88 | and (buffer[1] = _utf16BeBom[1]) then 89 | result := deUtf16BeBom; 90 | if (size >= 3) 91 | and (buffer[0] = _utf8Bom[0]) 92 | and (buffer[1] = _utf8Bom[1]) 93 | and (buffer[2] = _utf8Bom[2]) then 94 | result := deUtf8Bom; 95 | end; 96 | 97 | function CheckUtf8(buffer : TBytes) : TDetectEnc; 98 | var 99 | pos : integer; 100 | modeChars : integer; 101 | ch : byte; 102 | onlySawAsciiRange : boolean; 103 | size : longint; 104 | begin 105 | size := length(buffer); 106 | pos := 0; 107 | while pos < size do 108 | begin 109 | ch := buffer[pos]; 110 | pos += 1; 111 | if (ch = $00) and _nullSuggestsBinary then 112 | begin result := deNone; exit; end; 113 | 114 | if ch <= 127 then modeChars := 0 115 | else if (ch >= 194) and (ch <= 223) then modeChars := 1 116 | else if (ch >= 224) and (ch <= 239) then modeChars := 2 117 | else if (ch >= 240) and (ch <= 244) then modeChars := 4 118 | else 119 | begin result := deNone; exit; end; 120 | 121 | while (modechars > 0) and (pos < size) do 122 | begin 123 | onlySawAsciiRange := false; 124 | ch := buffer[pos]; 125 | pos += 1; 126 | if (ch < 127) or (ch > 191) then 127 | begin result := deNone; exit; end; 128 | modeChars -= 1; 129 | end; 130 | end; 131 | if onlySawAsciiRange then 132 | result := deAscii 133 | else 134 | result := deUtf8NoBom; 135 | end; 136 | 137 | 138 | function CheckUtf16NewLineChars(buffer : TBytes) : TDetectEnc; 139 | var 140 | leControlChars : integer; 141 | beControlChars : integer; 142 | pos : integer; 143 | ch1, ch2 : byte; 144 | size : longint; 145 | begin 146 | size := length(buffer); 147 | if size < 2 then 148 | begin 149 | result := deNone; 150 | exit; 151 | end; 152 | size -= 1; 153 | 154 | leControlChars := 0; 155 | beControlChars := 0; 156 | 157 | pos := 0; 158 | while pos < size do 159 | begin 160 | ch1 := buffer[pos]; 161 | pos += 1; 162 | ch2 := buffer[pos]; 163 | pos += 1; 164 | if ch1 = $00 then 165 | begin 166 | if (ch2 = $0A) or (ch2 = $0d) then 167 | beControlChars += 1; 168 | end 169 | else if ch2 = $00 then 170 | begin 171 | if (ch1 = $0a) or (ch1 = $0d) then 172 | leControlChars += 1; 173 | end; 174 | if (leControlChars > 0) and (beControlChars > 0) then 175 | begin result := deNone; exit; end; 176 | end; 177 | if leControlChars > 0 then 178 | begin result := deUtf16LeNoBom; exit; end; 179 | if beControlChars > 0 then 180 | result := deUtf16BeNoBom 181 | else 182 | result := deNone; 183 | end; 184 | 185 | function DoesContainNulls(buffer : TBytes) : boolean; 186 | var 187 | pos : integer; 188 | size : longint; 189 | begin 190 | size := length(buffer); 191 | pos := 0; 192 | result := false; 193 | while pos < size do 194 | begin 195 | if buffer[pos] = $00 then 196 | begin result := true; break; end; 197 | 198 | pos += 1; 199 | end; 200 | end; 201 | 202 | function CheckUtf16Ascii(buffer : TBytes) : TDetectEnc; 203 | var 204 | numOddNulls, 205 | numEvenNulls : integer; 206 | pos : integer; 207 | evenNullThreshold, 208 | oddNullThreshold, 209 | expectedNullThreshold, 210 | unexpectedNullThreashold : double; 211 | size : longint; 212 | begin 213 | size := length(buffer); 214 | numOddNulls := 0; 215 | numEvenNulls := 0; 216 | pos := 0; 217 | while pos < size do 218 | begin 219 | if buffer[pos] = $00 then 220 | numEvenNulls += 1; 221 | if pos + 1 < size then 222 | if buffer[pos + 1] = $00 then 223 | numOddNulls += 1; 224 | pos += 2; 225 | end; 226 | evenNullThreshold := numEvenNulls * 2.0 / size; 227 | oddNullThreshold := numOddNulls * 2.0 / size; 228 | expectedNullThreshold := _utf16ExpectedNullPercent / 100; 229 | unexpectedNullThreashold := _utf16UnexpectedNullPercent / 100; 230 | 231 | if (evenNullThreshold < unexpectedNullThreashold) and (oddNullThreshold > expectedNullThreshold) then 232 | begin result := deUtf16LeNoBom; exit end; 233 | 234 | if (oddNullThreshold < unexpectedNullThreashold) and (evenNullThreshold > expectedNullThreshold) then 235 | begin result := deUtf16BeBom; exit; end; 236 | 237 | result := deNone; 238 | end; 239 | 240 | function DetectEncoding(buffer : TBytes) : TDetectEnc; 241 | var 242 | encoding : TDetectEnc; 243 | size : longint; 244 | begin 245 | size := length(buffer); 246 | encoding := CheckBom(buffer); 247 | if encoding <> deNone then 248 | begin result := encoding; exit; end; 249 | 250 | encoding := CheckUtf8(buffer); 251 | if encoding <> deNone then 252 | begin result := encoding; exit; end; 253 | 254 | // encoding := CheckUtf16NewlineChars(buffer); 255 | // if encoding <> deNone then 256 | // begin result := encoding; exit; end; 257 | 258 | encoding := CheckUtf16Ascii(buffer); 259 | if encoding <> deNone then 260 | begin result := encoding; exit; end; 261 | 262 | if not DoesContainNulls(buffer) then 263 | begin result := deAnsi; exit; end; 264 | 265 | if _nullSuggestsBinary then 266 | result := deNone 267 | else 268 | result := deAnsi; 269 | 270 | end; 271 | 272 | end. 273 | 274 | -------------------------------------------------------------------------------- /vtxexportoptions.lfm: -------------------------------------------------------------------------------- 1 | object fExportOptions: TfExportOptions 2 | Left = 703 3 | Height = 123 4 | Top = 419 5 | Width = 265 6 | BorderStyle = bsDialog 7 | Caption = 'Export Options' 8 | ClientHeight = 123 9 | ClientWidth = 265 10 | LCLVersion = '1.6.4.0' 11 | object cbUseLineLen: TCheckBox 12 | Left = 14 13 | Height = 19 14 | Top = 12 15 | Width = 127 16 | Caption = 'Restrict Line Length:' 17 | TabOrder = 0 18 | end 19 | object cbUseSauce: TCheckBox 20 | Left = 14 21 | Height = 19 22 | Top = 32 23 | Width = 104 24 | Caption = 'Append SAUCE.' 25 | TabOrder = 1 26 | end 27 | object Button1: TButton 28 | Left = 102 29 | Height = 25 30 | Top = 92 31 | Width = 75 32 | Caption = 'OK' 33 | ModalResult = 1 34 | TabOrder = 2 35 | end 36 | object Button2: TButton 37 | Left = 180 38 | Height = 25 39 | Top = 92 40 | Width = 75 41 | Caption = 'Cancel' 42 | ModalResult = 2 43 | TabOrder = 3 44 | end 45 | object seLineLen: TSpinEdit 46 | Left = 179 47 | Height = 21 48 | Top = 10 49 | Width = 76 50 | Font.Height = -11 51 | MaxValue = 132 52 | MinValue = 40 53 | ParentFont = False 54 | TabOrder = 4 55 | Value = 79 56 | end 57 | object cbStaticObjects: TCheckBox 58 | Left = 14 59 | Height = 19 60 | Top = 52 61 | Width = 95 62 | Caption = 'Static Objects.' 63 | TabOrder = 5 64 | end 65 | object cbUseBOM: TCheckBox 66 | Left = 14 67 | Height = 19 68 | Top = 70 69 | Width = 135 70 | Caption = 'Prefix Encoding BOM.' 71 | TabOrder = 6 72 | end 73 | end 74 | -------------------------------------------------------------------------------- /vtxexportoptions.lrs: -------------------------------------------------------------------------------- 1 | { This is an automatically generated lazarus resource file } 2 | 3 | LazarusResources.Add('TfExportOptions','FORMDATA',[ 4 | 'TPF0'#15'TfExportOptions'#14'fExportOptions'#4'Left'#3#191#2#6'Height'#2'{'#3 5 | +'Top'#3#163#1#5'Width'#3#9#1#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#14'E' 6 | +'xport Options'#12'ClientHeight'#2'{'#11'ClientWidth'#3#9#1#10'LCLVersion'#6 7 | +#7'1.6.4.0'#0#9'TCheckBox'#12'cbUseLineLen'#4'Left'#2#14#6'Height'#2#19#3'To' 8 | +'p'#2#12#5'Width'#2#127#7'Caption'#6#21'Restrict Line Length:'#8'TabOrder'#2 9 | +#0#0#0#9'TCheckBox'#10'cbUseSauce'#4'Left'#2#14#6'Height'#2#19#3'Top'#2' '#5 10 | +'Width'#2'h'#7'Caption'#6#13'Append SAUCE.'#8'TabOrder'#2#1#0#0#7'TButton'#7 11 | +'Button1'#4'Left'#2'f'#6'Height'#2#25#3'Top'#2'\'#5'Width'#2'K'#7'Caption'#6 12 | +#2'OK'#11'ModalResult'#2#1#8'TabOrder'#2#2#0#0#7'TButton'#7'Button2'#4'Left' 13 | +#3#180#0#6'Height'#2#25#3'Top'#2'\'#5'Width'#2'K'#7'Caption'#6#6'Cancel'#11 14 | +'ModalResult'#2#2#8'TabOrder'#2#3#0#0#9'TSpinEdit'#9'seLineLen'#4'Left'#3#179 15 | +#0#6'Height'#2#21#3'Top'#2#10#5'Width'#2'L'#11'Font.Height'#2#245#8'MaxValue' 16 | +#3#132#0#8'MinValue'#2'('#10'ParentFont'#8#8'TabOrder'#2#4#5'Value'#2'O'#0#0 17 | +#9'TCheckBox'#15'cbStaticObjects'#4'Left'#2#14#6'Height'#2#19#3'Top'#2'4'#5 18 | +'Width'#2'_'#7'Caption'#6#15'Static Objects.'#8'TabOrder'#2#5#0#0#9'TCheckBo' 19 | +'x'#8'cbUseBOM'#4'Left'#2#14#6'Height'#2#19#3'Top'#2'F'#5'Width'#3#135#0#7'C' 20 | +'aption'#6#20'Prefix Encoding BOM.'#8'TabOrder'#2#6#0#0#0 21 | ]); 22 | -------------------------------------------------------------------------------- /vtxexportoptions.pas: -------------------------------------------------------------------------------- 1 | unit VTXExportOptions; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, 9 | StdCtrls, Spin; 10 | 11 | type 12 | 13 | { TfExportOptions } 14 | 15 | TfExportOptions = class(TForm) 16 | Button1: TButton; 17 | Button2: TButton; 18 | cbUseLineLen: TCheckBox; 19 | cbUseSauce: TCheckBox; 20 | cbStaticObjects: TCheckBox; 21 | cbUseBOM: TCheckBox; 22 | seLineLen: TSpinEdit; 23 | private 24 | { private declarations } 25 | public 26 | { public declarations } 27 | end; 28 | 29 | var 30 | fExportOptions: TfExportOptions; 31 | 32 | implementation 33 | 34 | { TfExportOptions } 35 | 36 | initialization 37 | {$I vtxexportoptions.lrs} 38 | 39 | end. 40 | 41 | -------------------------------------------------------------------------------- /vtxpreviewbox.lfm: -------------------------------------------------------------------------------- 1 | object fPreview: TfPreview 2 | Left = 1194 3 | Height = 363 4 | Top = 262 5 | Width = 300 6 | BorderIcons = [] 7 | BorderStyle = bsSizeToolWin 8 | Caption = 'Preview' 9 | ClientHeight = 363 10 | ClientWidth = 300 11 | FormStyle = fsStayOnTop 12 | OnCreate = FormCreate 13 | OnShow = FormShow 14 | ShowInTaskBar = stNever 15 | LCLVersion = '1.6.4.0' 16 | object ScrollBox1: TScrollBox 17 | Left = 0 18 | Height = 363 19 | Top = 0 20 | Width = 300 21 | HorzScrollBar.Increment = 10 22 | HorzScrollBar.Page = 105 23 | HorzScrollBar.Smooth = True 24 | HorzScrollBar.Tracking = True 25 | VertScrollBar.Increment = 10 26 | VertScrollBar.Page = 106 27 | VertScrollBar.Smooth = True 28 | VertScrollBar.Tracking = True 29 | Anchors = [akTop, akLeft, akRight, akBottom] 30 | ClientHeight = 359 31 | ClientWidth = 296 32 | Color = clBlack 33 | ParentColor = False 34 | TabOrder = 0 35 | OnPaint = ScrollBox1Paint 36 | object pbPreview: TPaintBox 37 | Left = 0 38 | Height = 105 39 | Top = 1 40 | Width = 105 41 | Align = alCustom 42 | Color = clBlack 43 | ParentColor = False 44 | OnPaint = pbPreviewPaint 45 | end 46 | end 47 | end 48 | -------------------------------------------------------------------------------- /vtxpreviewbox.pas: -------------------------------------------------------------------------------- 1 | { 2 | 3 | BSD 2-Clause License 4 | 5 | Copyright (c) 2017, Daniel Mecklenburg Jr. All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | } 29 | 30 | unit VTXPreviewBox; 31 | 32 | {$mode objfpc}{$H+} 33 | 34 | interface 35 | 36 | uses 37 | Classes, 38 | {$ifdef WINDOWS} Windows, {$endif} 39 | Forms, 40 | Graphics, 41 | ExtCtrls, 42 | VTXConst, 43 | VTXSupport, 44 | math, 45 | BGRABitmap, 46 | BGRABitmapTypes 47 | ; 48 | 49 | type 50 | 51 | { TfPreview } 52 | 53 | TfPreview = class(TForm) 54 | pbPreview: TPaintBox; 55 | ScrollBox1: TScrollBox; 56 | procedure FormCreate(Sender: TObject); 57 | procedure FormShow(Sender: TObject); 58 | procedure pbPreviewPaint(Sender: TObject); 59 | procedure ScrollBox1Paint(Sender: TObject); 60 | private 61 | { private declarations } 62 | public 63 | { public declarations } 64 | end; 65 | 66 | var 67 | fPreview : TfPreview; 68 | ScrollWidth : integer; 69 | 70 | implementation 71 | 72 | {$R *.lfm} 73 | 74 | { TfPreview } 75 | procedure TfPreview.FormCreate(Sender: TObject); 76 | {$ifdef WINDOWS} 77 | var 78 | loc_SBInfo : TNonCLientMetrics; 79 | {$endif} 80 | begin 81 | DoubleBuffered:=true; 82 | {$ifdef WINDOWS} 83 | loc_SBInfo.cbSize := SizeOf(loc_SBInfo); 84 | SystemParametersInfo(SPI_GetNonClientMetrics,0,@loc_SBInfo,0); 85 | ScrollWidth := loc_SBInfo.iScrollWidth; 86 | {$else} 87 | // calculate scrollbar width. 88 | {$endif} 89 | end; 90 | 91 | procedure TfPreview.ScrollBox1Paint(Sender: TObject); 92 | var 93 | fw, w, h : integer; 94 | begin 95 | // set size of pbPreview to max zoom out for bmpPage 96 | if bmpPreview = nil then exit; 97 | 98 | w := floor(bmpPreview.Width * XScale); 99 | h := bmpPreview.Height; 100 | fw := w + 8; 101 | 102 | if h > ScrollBox1.ClientHeight then 103 | fw += ScrollWidth + 2; 104 | 105 | if width <> fw then 106 | begin 107 | self.Constraints.MaxWidth:=fw; 108 | self.Constraints.MinWidth:=fw; 109 | self.Width := fw; 110 | end; 111 | if pbPreview.Width <> w then 112 | pbPreview.Width := w; 113 | 114 | if pbPreview.Height <> h then 115 | pbPreview.Height := h; 116 | end; 117 | 118 | // this routine needs better looking / faster update 119 | // maybe drop the tscrollbox, move to panel/image, add scrollbars, 120 | // and only draw displayable chunk? 121 | procedure TfPreview.pbPreviewPaint(Sender: TObject); 122 | var 123 | pb : TPaintBox; 124 | cnv : TCanvas; 125 | bmp, bmp2 : TBGRABitmap; 126 | i, r, c, x, y : integer; 127 | off : longint; 128 | cell : TCell; 129 | cp : TEncoding; 130 | objonrow : boolean; 131 | objnum : integer; 132 | neighbors : byte; 133 | begin 134 | if (bmpPreview = nil) then exit; 135 | 136 | pb := TPaintBox(Sender); 137 | cnv := pb.Canvas; 138 | if XScale = 1 then 139 | cnv.Draw(0, 0, bmpPreview.Bitmap) 140 | else 141 | begin 142 | bmpPreview.ResampleFilter := rfMitchell; 143 | bmp2 := bmpPreview.Resample(pb.Width, pb.Height, rmFineResample) as TBGRABitmap; 144 | cnv.Draw(0, 0, bmp2.Bitmap); 145 | bmp2.Free; 146 | end; 147 | 148 | // draw objects over top 149 | // from topmost to bottommost 150 | bmp := TBGRABitmap.Create(8, 16); 151 | for r := 0 to NumRows - 1do 152 | begin 153 | // any objects on this row? 154 | y := (r << 2); 155 | for c := 0 to NumCols - 1 do 156 | begin 157 | x := floor((c << 1) * XScale); 158 | objnum := GetObjectCell(r, c, cell); 159 | if (objnum >= 0) and (not Objects[objnum].Hidden) then 160 | if cell.Chr <> _EMPTY then 161 | begin 162 | // object here. 163 | cp := Fonts[GetBits(cell.Attr, A_CELL_FONT_MASK, 28)]; 164 | if (cp = encUTF8) or (cp = encUTF16) then 165 | off := GetGlyphOff(cell.Chr, CPages[cp].GlyphTable, CPages[cp].GlyphTableSize) 166 | else 167 | begin 168 | if cell.Chr > 255 then cell.Chr := 0; 169 | off := CPages[cp].QuickGlyph[cell.Chr]; 170 | end; 171 | GetGlyphBmp(bmp, CPages[cp].GlyphTable, off, cell.Attr, false); 172 | // bmp.ResampleFilter:=rfMitchell; 173 | bmp2 := bmp.Resample(round(2 * XScale), 4, rmFineResample) as TBGRABitmap; 174 | cnv.Draw(x, y, bmp2.Bitmap); 175 | bmp2.free; 176 | end; 177 | end; 178 | end; 179 | bmp.free; 180 | end; 181 | 182 | procedure TfPreview.FormShow(Sender: TObject); 183 | var 184 | h, w, fw : integer; 185 | begin 186 | if bmpPage = nil then exit; 187 | 188 | w := floor(bmpPreview.Width * XScale); 189 | h := bmpPreview.Height; 190 | fw := w + 8; 191 | 192 | if h > ScrollBox1.ClientHeight then 193 | fw += ScrollWidth + 2; 194 | 195 | if Width <> fw then 196 | begin 197 | self.Constraints.MaxWidth:=fw; 198 | self.Constraints.MinWidth:=fw; 199 | self.Width := fw; 200 | end; 201 | 202 | if pbPreview.Width <> w then 203 | pbPreview.Width := w; 204 | 205 | if pbPreview.Height <> h then 206 | pbPreview.Height := h; 207 | end; 208 | 209 | end. 210 | 211 | -------------------------------------------------------------------------------- /vtxsupport.pas: -------------------------------------------------------------------------------- 1 | { 2 | 3 | BSD 2-Clause License 4 | 5 | Copyright (c) 2017, Daniel Mecklenburg Jr. All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | } 29 | 30 | unit VTXSupport; 31 | 32 | {$mode objfpc}{$H+} 33 | {$modeswitch advancedrecords} 34 | {$ASMMODE intel} 35 | 36 | interface 37 | 38 | uses 39 | UnicodeHelper, 40 | Classes, 41 | Forms, 42 | SysUtils, 43 | ExtCtrls, 44 | VTXConst, 45 | BGRABitmap, 46 | BGRABitmapTypes, 47 | RecList, 48 | Math, 49 | {$ifdef WINDOWS} 50 | Windows, 51 | {$else} 52 | LCLType, 53 | {$endif} 54 | Graphics; 55 | 56 | procedure DrawDashLine(cnv : TCanvas; x1, y1, x2, y2 : integer; clr1, clr2 : TColor); 57 | procedure DrawDashRect(cnv : TCanvas; rect : TRect; clr1, clr2 : TColor); 58 | procedure DrawDashRect(cnv : TCanvas; x1, y1, x2, y2 : integer; clr1, clr2 : TColor); 59 | function GetGlyphOff(codepoint : integer; table : PByte; size : integer) : integer; 60 | procedure GetGlyphBmp(var bmp : TBGRABitmap; base : pbyte; off : integer; attr : Uint32; blink : boolean); 61 | function Between(val, lo, hi : integer) : boolean; inline; 62 | function Between(val, lo, hi : char) : boolean; inline; 63 | function HasBits(val, mask : UInt32) : boolean; inline; 64 | function GetBits(val, mask : UInt32; shift : integer = 0) : UInt32; inline; 65 | procedure SetBits(var val : UInt32; mask, bits : UInt32; shift : integer = 0); inline; 66 | procedure SetBit(var val : byte; mask : byte; bit : boolean); inline; 67 | procedure SetBit(var val : UInt32; mask : UInt32; bit : boolean); inline; 68 | procedure SetBit(var val : longint; mask : longint; bit : boolean); inline; 69 | procedure Swap(var val1, val2 : integer); inline; 70 | procedure Swap(var val1, val2 : UInt32); inline; 71 | function Brighten(color : TColor; factor: real): TColor; 72 | function DrawTextCentered(cnv: TCanvas; const r: TRect; s: unicodeString): Integer; 73 | function DrawTextRight(cnv: TCanvas; const r: TRect; s: unicodeString): Integer; 74 | procedure DrawRectangle(cnv: TCanvas; x1, y1, x2, y2 : integer; clr : TColor); 75 | procedure DrawRectangle(cnv: TCanvas; rect : TRect; clr : TColor); 76 | procedure LineCalcInit(x0, y0, x1, y1 : integer); 77 | function LineCalcNext(var xo, yo : integer) : boolean; 78 | procedure EllipseCalcInit(xrad, yrad : longint); 79 | function EllipseCalcNext(var xo, yo : longint) : boolean; 80 | function QuadToStr(q : TQuad) : unicodestring; 81 | function StrToQuad(str : unicodestring) : TQuad; 82 | procedure SetFormQuad(f : TForm; q : TQuad); 83 | function GetFormQuad(f : TForm) : TQuad; 84 | function CharsToStr(src : array of char; len : integer) : unicodestring; 85 | function CharsToStr(src : array of byte; len : integer) : unicodestring; 86 | function isInteger(str : unicodestring) : boolean; 87 | function iif(cond : boolean; trueval, falseval : integer) : integer; inline; 88 | function iif(cond : boolean; trueval, falseval : byte) : byte; inline; 89 | function iif(cond : boolean; trueval, falseval : char) : char; inline; 90 | function iif(cond : boolean; trueval, falseval : string) : string; inline; 91 | function iif(cond : boolean; trueval, falseval : unicodestring) : unicodestring; inline; 92 | function iif(cond : boolean; trueval, falseval : uint32) : uint32; inline; 93 | function RectWidth(r : TRect) : integer; inline; 94 | function RectHeight(r : TRect) : integer; inline; 95 | procedure DrawStretchedBitmap(cnv : TCanvas; r : TRect; bmp : TBGRABitmap); 96 | function GetObjectCell(row, col : integer; var cell : TCell) : integer; 97 | function InRect(x, y, rx, ry, rw, rh : integer) : boolean; inline; 98 | operator =(cell1, cell2 : TCell) : boolean; 99 | procedure Draw3DRect(cnv : TCanvas; rect : TRect; sunk : boolean); 100 | procedure Draw3DRect(cnv : TCanvas; x1, y1, x2, y2 : integer; sunk : boolean); 101 | 102 | var 103 | // various settings 104 | PageType : integer; // from cbPageType PAGETYPE_ 105 | ColorScheme : integer; // from cbColorScheme COLORSCHEME_ 106 | 107 | bmpPage : TBGRABitmap; // the page. 108 | bmpPreview : TBGRABitmap; 109 | PageZoom : double; // 1.0 = 100% 110 | XScale : double; // horizontal stretch. 1.0 = 100% 111 | CellWidth, CellHeight : integer; // pixels 112 | CellWidthZ, CellHeightZ : integer; // adjusted by PageZoom 113 | NumCols, NumRows : integer; // doc size 114 | 115 | Page : TPage; // main doc 116 | 117 | // objects on doc 118 | Objects : TObjList; 119 | 120 | // as cells are painted, updates get added to this. keep the original cell, 121 | // and update the new cell with the last cell painted. 122 | CurrUndoData : TRecList; 123 | 124 | // the undo/redo list 125 | UndoPos : integer; // where are we on the undo list 126 | Undo : TRecList; // the list 127 | 128 | // fonts. (CSI 10-19 / 80-85 <space> D 129 | Fonts : array [0..15] of TEncoding; 130 | 131 | KeyBinds : array of TKeyBinds; 132 | 133 | implementation 134 | 135 | operator =(cell1, cell2 : TCell) : boolean; 136 | begin 137 | result := (cell1.Chr = cell2.Chr) and (cell1.Attr = cell2.Attr); 138 | end; 139 | 140 | {*****************************************************************************} 141 | 142 | { Support Functions } 143 | 144 | function InRect(x, y, rx, ry, rw, rh : integer) : boolean; inline; 145 | begin 146 | result := (x >= rx) and (x < rx + rw) and (y >= ry) and (y < ry + rh); 147 | end; 148 | 149 | function GetObjectCell(row, col : integer; var cell : TCell) : integer; 150 | var 151 | i : integer; 152 | objr, objc, p : integer; 153 | cellrec : TCell; 154 | begin 155 | for i := length(Objects) - 1 downto 0 do 156 | begin 157 | if InRect( 158 | col, row, 159 | Objects[i].Col, Objects[i].Row, 160 | Objects[i].Width, Objects[i].Height) then 161 | begin 162 | objr := row - Objects[i].Row; 163 | objc := col - Objects[i].Col; 164 | p := objr * Objects[i].Width + objc; 165 | 166 | Objects[i].Data.Get(@cellrec, p); 167 | if cellrec.Chr <> _EMPTY then 168 | begin 169 | cell := cellrec; 170 | exit(i); 171 | end; 172 | end; 173 | end; 174 | cell.Chr := _EMPTY; 175 | cell.Attr := $0007; 176 | result := -1; 177 | end; 178 | 179 | function VTXRGB(r, g, b : byte) : dword; inline; 180 | begin 181 | result := ((b << 16) or (g << 8) or r); 182 | end; 183 | 184 | function iif(cond : boolean; trueval, falseval : uint32) : uint32; inline; 185 | begin 186 | if cond then result := trueval else result := falseval; 187 | end; 188 | 189 | function iif(cond : boolean; trueval, falseval : unicodestring) : unicodestring; inline; 190 | begin 191 | if cond then result := trueval else result := falseval; 192 | end; 193 | 194 | function iif(cond : boolean; trueval, falseval : string) : string; inline; 195 | begin 196 | if cond then result := trueval else result := falseval; 197 | end; 198 | 199 | function iif(cond : boolean; trueval, falseval : char) : char; inline; 200 | begin 201 | if cond then result := trueval else result := falseval; 202 | end; 203 | 204 | function iif(cond : boolean; trueval, falseval : integer) : integer; inline; 205 | begin 206 | if cond then result := trueval else result := falseval; 207 | end; 208 | 209 | function iif(cond : boolean; trueval, falseval : byte) : byte; inline; 210 | begin 211 | if cond then result := trueval else result := falseval; 212 | end; 213 | 214 | // get offset of codepoint of glyph in UVGA16. return 0 if not found 215 | // called like GetGlyphOff(9673, @UVGA16, sizeof(UVGA16)); 216 | function GetGlyphOff(codepoint : integer; table : PByte; size : integer) : integer; 217 | var 218 | rec, min, max : integer; 219 | key, off : integer; 220 | recs : integer; 221 | begin 222 | recs := size div 18; 223 | 224 | // do binary search for codepoint in glyphtable 225 | min := 0; 226 | max := recs; 227 | repeat 228 | if max < min then 229 | begin 230 | // not found! return 0 (the undef char) 231 | off := 0; 232 | break; 233 | end; 234 | 235 | rec := (max + min) >> 1; 236 | off := rec * 18; 237 | key := (table[off] << 8) or table[off + 1]; 238 | 239 | if key = codepoint then 240 | // got a match. exit with off 241 | break; 242 | 243 | if key < codepoint then 244 | min := rec + 1 245 | else if key > codepoint then 246 | max := rec - 1; 247 | 248 | until key = codepoint; 249 | result := off + 2; 250 | end; 251 | 252 | // return new rendered glyph - does not render blink or double height 253 | procedure GetGlyphBmp( 254 | var bmp : TBGRABitmap; 255 | base : pbyte; // base address of glyph table 256 | off : integer; // offset into glyph table points to 8x16 257 | attr : Uint32; // standard cell attributes 258 | blink : boolean // if on, conceal text. 259 | ); 260 | var 261 | x, y : Integer; 262 | b : Word; 263 | ptr : PBYTE; 264 | bptr : PBGRAPixel; 265 | sptr : PBGRAPixel; 266 | fg, bg, sc : TBGRAPixel; 267 | italics, 268 | bold, 269 | shadow, 270 | underline, 271 | strike, 272 | dstrike : Boolean; 273 | disp : Integer; 274 | adj : Integer; 275 | i, dl : Integer; 276 | s : PBGRAPixel; 277 | fi, bi : Integer; 278 | begin 279 | ptr := @base[off]; 280 | 281 | italics := HasBits(attr, A_CELL_ITALICS); 282 | bold := HasBits(attr, A_CELL_BOLD); 283 | shadow := HasBits(attr, A_CELL_SHADOW); 284 | underline := HasBits(attr, A_CELL_UNDERLINE); 285 | strike := HasBits(attr, A_CELL_STRIKETHROUGH); 286 | dstrike := HasBits(attr, A_CELL_DOUBLESTRIKE); 287 | disp := GetBits(attr, A_CELL_DISPLAY_MASK); 288 | 289 | // dont' swap bold bit if BBS or CTerm and colors between 8-15 290 | fi := GetBits(attr, A_CELL_FG_MASK); 291 | bi := GetBits(attr, A_CELL_BG_MASK, 8); 292 | if HasBits(attr, A_CELL_REVERSE) then 293 | begin 294 | if ColorScheme = COLORSCHEME_BBS then 295 | begin 296 | i := fi and $08; 297 | fi := fi and $07; 298 | bi := bi or i; 299 | end; 300 | fg := ANSIColor[bi]; 301 | bg := ANSIColor[fi]; 302 | end 303 | else 304 | begin 305 | fg := ANSIColor[fi]; 306 | bg := ANSIColor[bi]; 307 | end; 308 | 309 | // get faint foreground color 310 | if HasBits(attr, A_CELL_FAINT) then 311 | fg := Brighten(fg, -0.33); 312 | 313 | // compute shadow color 314 | if shadow then 315 | sc := Brighten(bg, -0.33); 316 | 317 | // draw background. 318 | bmp.FillRect(0, 0, 8, 16, bg); 319 | 320 | // draw the cell 321 | if not blink and (disp <> A_CELL_DISPLAY_CONCEAL) then 322 | begin 323 | 324 | for y := 0 to 15 do 325 | begin 326 | bptr := bmp.ScanLine[y]; // get ptr into bmp 327 | if (y < 15) then 328 | begin 329 | sptr := bmp.ScanLine[y + 1]; // get ptr for shadow 330 | sptr += 1; 331 | end; 332 | 333 | b := ptr^; // get byte of character def 334 | inc(ptr); 335 | 336 | // alter for underline, strikethrough, and doublestrike 337 | if underline and (y = 15) then b := $ff; 338 | if strike and (y = 7) then b := $ff; 339 | if dstrike and ((y = 3) or (y = 11)) then b := $ff; 340 | 341 | // build bits 342 | for x := 0 to 7 do 343 | begin 344 | // if bit on at this x,y for this character 345 | if (b and $80) <> 0 then 346 | begin 347 | // shift top portion of bitmap 1 px right for italics 348 | adj := 0; 349 | if italics and (y < 8) then 350 | inc(adj); 351 | 352 | // draw if on the bitmap 353 | if x + adj < 8 then 354 | begin 355 | // draw shadow color bit first 356 | if shadow and (x + adj < 7) and (y < 15) then 357 | sptr[adj] := sc; 358 | 359 | // if shadow and (y > 0) and (x + adj < 7) then 360 | // bptr[adj - 7] := sc; 361 | 362 | // draw character bit 363 | bptr[adj] := fg; 364 | 365 | // repeat for bold 366 | if bold and (x + adj < 7) then 367 | bptr[adj + 1] := fg; 368 | 369 | end; 370 | end; 371 | bptr += 1; 372 | sptr += 1; 373 | b := b << 1; 374 | end; 375 | end; 376 | 377 | // adjust for double height 378 | if disp = A_CELL_DISPLAY_TOP then 379 | begin 380 | // stretch top half down over entire cell 381 | for i := 7 downto 0 do 382 | begin 383 | s := bmp.ScanLine[i]; 384 | dl := i << 1; 385 | Move(s[0], bmp.ScanLine[dl ][0], 32); 386 | Move(s[0], bmp.ScanLine[dl + 1][0], 32); 387 | end; 388 | end 389 | 390 | else if disp = A_CELL_DISPLAY_BOTTOM then 391 | begin 392 | // stretch bottom half up over entire cell 393 | for i := 8 to 15 do 394 | begin 395 | s := bmp.ScanLine[i]; 396 | dl := (i - 8) << 1; 397 | Move(s[0], bmp.ScanLine[dl ][0], 32); 398 | Move(s[0], bmp.ScanLine[dl + 1][0], 32); 399 | end; 400 | end; 401 | 402 | // bmp.InvalidateBitmap; 403 | end; 404 | end; 405 | 406 | // is val between lo and hi? 407 | function Between(val, lo, hi : integer) : boolean; inline; 408 | begin 409 | result := ((val >= lo) and (val <= hi)); 410 | end; 411 | 412 | // is val between lo and hi? 413 | function Between(val, lo, hi : char) : boolean; inline; 414 | begin 415 | result := ((ord(val) >= ord(lo)) and (ord(val) <= ord(hi))); 416 | end; 417 | 418 | // any bits set? 419 | function HasBits(val, mask : UInt32) : boolean; inline; 420 | begin 421 | result := ((val and mask) <> 0); 422 | end; 423 | 424 | // return bits under bitmask 425 | function GetBits(val, mask : UInt32; shift : integer = 0) : UInt32; inline; 426 | begin 427 | result := ((val and mask) >> shift); 428 | end; 429 | 430 | // set bits for bitmask 431 | procedure SetBits(var val : UInt32; mask, bits : UInt32; shift : integer = 0); inline; 432 | begin 433 | val := ((val and not mask) or ((bits << shift) and mask)); 434 | end; 435 | 436 | procedure SetBit(var val : byte; mask : byte; bit : boolean); 437 | var 438 | bitval : byte; 439 | begin 440 | bitval := mask; 441 | if not bit then 442 | bitval := 0; 443 | val := ((val and not mask) or bitval); 444 | end; 445 | 446 | procedure SetBit(var val : UInt32; mask : UInt32; bit : boolean); 447 | var 448 | bitval : UInt32; 449 | begin 450 | bitval := mask; 451 | if not bit then 452 | bitval := 0; 453 | val := ((val and not mask) or bitval); 454 | end; 455 | 456 | procedure SetBit(var val : longint; mask : longint; bit : boolean); 457 | var 458 | bitval : longint; 459 | begin 460 | bitval := mask; 461 | if not bit then 462 | bitval := 0; 463 | val := ((val and not mask) or bitval); 464 | end; 465 | 466 | procedure Swap(var val1, val2 : integer); inline; 467 | var 468 | tmp : integer; 469 | begin 470 | tmp := val1; val1 := val2; val2 := tmp; 471 | end; 472 | 473 | procedure Swap(var val1, val2 : UInt32); inline; 474 | var 475 | tmp : UInt32; 476 | begin 477 | tmp := val1; val1 := val2; val2 := tmp; 478 | end; 479 | 480 | // brighten / darken color 481 | function Brighten(color : TColor; factor: real): TColor; 482 | 483 | function Norm(val : byte) : double; inline; 484 | begin 485 | result := val / 255.0; 486 | end; 487 | 488 | function Unnorm(val : double) : byte; inline; 489 | begin 490 | result := round(val * 255.0); 491 | end; 492 | 493 | var 494 | r, g, b : double; 495 | begin 496 | r := Norm(Red(color)); 497 | g := Norm(Green(color)); 498 | b := Norm(Blue(color)); 499 | if factor < 0 then 500 | begin 501 | factor := factor + 1.0; 502 | r := r * factor; 503 | g := g * factor; 504 | b := b * factor; 505 | end 506 | else 507 | begin 508 | r := (1.0 - r) * factor + r; 509 | g := (1.0 - g) * factor + g; 510 | b := (1.0 - b) * factor + b; 511 | end; 512 | result := VTXRGB(Unnorm(r), Unnorm(g), Unnorm(b)); 513 | end; 514 | 515 | function RectWidth(r : TRect) : integer; inline; 516 | begin 517 | result := r.Right - r.Left; 518 | end; 519 | 520 | function RectHeight(r : TRect) : integer; inline; 521 | begin 522 | result := r.Bottom - r.Top; 523 | end; 524 | 525 | function DrawTextCentered(cnv : TCanvas; const r : TRect; s : unicodeString) : integer; 526 | var 527 | sz : TSize; 528 | begin 529 | sz := cnv.TextExtent(s); 530 | cnv.TextOut(r.Left + ((RectWidth(r) - sz.cx) >> 1), r.Top + ((RectHeight(r) - sz.cy) >> 1), s); 531 | end; 532 | 533 | function DrawTextRight(cnv : TCanvas; const r : TRect; s : unicodeString) : integer; 534 | var 535 | sz : TSize; 536 | rtop, rleft, rright, rwidth, rheight : integer; 537 | begin 538 | sz := cnv.TextExtent(s); 539 | rtop := r.top; 540 | rleft := r.left; 541 | rright := r.right; 542 | rwidth := RectWidth(r); 543 | rheight := RectHeight(r); 544 | if rheight < sz.cy then 545 | rheight := sz.cy; 546 | cnv.TextOut(rright - sz.cx, rtop + ((rheight - sz.cy) >> 1), s); 547 | end; 548 | 549 | procedure DrawRectangle(cnv: TCanvas; rect : TRect; clr : TColor); 550 | begin 551 | DrawRectangle(cnv, rect.Left, rect.Top, rect.Right - 1, rect.Bottom - 1, clr); 552 | end; 553 | 554 | procedure DrawRectangle(cnv: TCanvas; x1, y1, x2, y2 : integer; clr : TColor); 555 | begin 556 | cnv.Pen.Color := clr; 557 | cnv.Line(x2, y1, x1, y1); 558 | cnv.Line(x1, y1, x1, y2); 559 | cnv.Line(x1, y2, x2, y2); 560 | cnv.Line(x2, y2, x2, y1); 561 | end; 562 | 563 | // http://members.chello.at/~easyfilter/bresenham.html 564 | 565 | // encapsulated line plotting globals 566 | var 567 | LineData : record 568 | calcX0, calcY0, 569 | calcX1, calcY1 : longint; 570 | calcDX, calcDY, 571 | calcSX, calcSY : longint; 572 | calcErr : longint; 573 | end; 574 | 575 | // initialize line plotting calculator 576 | procedure LineCalcInit(x0, y0, x1, y1 : longint); 577 | begin 578 | LineData.calcX0 := x0; 579 | LineData.calcY0 := y0; 580 | LineData.calcX1 := x1; 581 | LineData.calcY1 := y1; 582 | with LineData do 583 | begin 584 | calcDX := abs(x1 - x0); 585 | calcDY := abs(y1 - y0); 586 | if x0 < x1 then 587 | calcSX := 1 588 | else 589 | calcSX := -1; 590 | if y0 < y1 then 591 | calcSY := 1 592 | else 593 | calcSY := -1; 594 | if calcDX > calcDY then 595 | calcErr := calcDX div 2 596 | else 597 | calcErr := (-calcDY) div 2; 598 | end; 599 | end; 600 | 601 | // get next point 602 | function LineCalcNext(var xo, yo : longint) : boolean; 603 | var 604 | e2 : longint; 605 | begin 606 | with LineData do 607 | begin 608 | result := ((calcX0 = calcX1) and (calcY0 = calcY1)); 609 | if not result then 610 | begin 611 | e2 := calcErr; 612 | if e2 > -calcDX then 613 | begin 614 | calcErr -= calcDY; 615 | calcX0 += calcSX; 616 | end; 617 | if e2 < calcDY then 618 | begin 619 | calcErr += calcDX; 620 | calcY0 += calcSY; 621 | end; 622 | result := ((calcX0 = calcX1) and (calcY0 = calcY1)); 623 | end; 624 | xo := calcX0; 625 | yo := calcY0; 626 | end; 627 | end; 628 | 629 | // encapsulated ellipse plotting globals 630 | var 631 | EllipseData : record 632 | State : integer; 633 | X, Y : longint; 634 | TwoASquare, TwoBSquare : longint; 635 | XChange, YChange : longint; 636 | EllipseError : longint; 637 | StoppingX, StoppingY : longint; 638 | XRadius, YRadius : longint; 639 | end; 640 | 641 | procedure EllipseCalcInit(xrad, yrad : longint); 642 | begin 643 | EllipseData.XRadius := xrad; 644 | EllipseData.YRadius := yrad; 645 | EllipseData.State := 0; 646 | 647 | end; 648 | 649 | function EllipseCalcNext(var xo, yo : longint) : boolean; 650 | begin 651 | result := false; 652 | with EllipseData do 653 | begin 654 | if (XRadius = 0) or (YRadius = 0) then 655 | begin 656 | xo := 0; 657 | yo := 0; 658 | result := true; 659 | exit; 660 | end; 661 | case State of 662 | 0, 1: 663 | begin 664 | if State = 0 then 665 | begin 666 | // init for first part of ellipse 667 | TwoASquare := 2 * XRadius * XRadius; 668 | TwoBSquare := 2 * YRadius * YRadius; 669 | X := XRadius; 670 | Y := 0; 671 | XChange := YRadius * YRadius * (1 - 2 * XRadius); 672 | YChange := XRadius * XRadius; 673 | EllipseError := 0; 674 | StoppingX := TwoBSquare * XRadius; 675 | StoppingY := 0; 676 | State := 1; 677 | end; 678 | if StoppingX >= StoppingY then 679 | begin 680 | // the results. 681 | xo := X; 682 | yo := Y; 683 | y += 1; 684 | inc(StoppingY, TwoASquare); 685 | inc(EllipseError, YChange); 686 | inc(YChange, TwoASquare); 687 | if ((2 * EllipseError + XChange) > 0) then 688 | begin 689 | x -= 1; 690 | dec(StoppingX, TwoBSquare); 691 | inc(EllipseError, XChange); 692 | inc(XChange, TwoBSquare) 693 | end; 694 | end 695 | else 696 | begin 697 | X := 0; 698 | Y := YRadius; 699 | XChange := YRadius * YRadius; 700 | YChange := XRadius * XRadius * (1 - 2 * YRadius); 701 | EllipseError := 0; 702 | StoppingX := 0; 703 | StoppingY := TwoASquare * YRadius; 704 | State := 2; 705 | 706 | if StoppingX <= StoppingY then 707 | begin 708 | // the results. 709 | xo := X; 710 | yo := Y; 711 | x += 1;; 712 | inc(StoppingX, TwoBSquare); 713 | inc(EllipseError, XChange); 714 | inc(XChange, TwoBSquare); 715 | if ((2 * EllipseError + YChange) > 0) then 716 | begin 717 | y -= 1; 718 | dec(StoppingY, TwoASquare); 719 | inc(EllipseError, YChange); 720 | inc(YChange, TwoASquare) 721 | end; 722 | end 723 | else 724 | begin 725 | // done 726 | xo := x; 727 | yo := y; 728 | result := true; 729 | end; 730 | end; 731 | end; 732 | 733 | 2: 734 | begin 735 | if StoppingX <= StoppingY then 736 | begin 737 | // the results. 738 | xo := X; 739 | yo := Y; 740 | x += 1;; 741 | inc(StoppingX, TwoBSquare); 742 | inc(EllipseError, XChange); 743 | inc(XChange, TwoBSquare); 744 | if ((2 * EllipseError + YChange) > 0) then 745 | begin 746 | y -= 1; 747 | dec(StoppingY, TwoASquare); 748 | inc(EllipseError, YChange); 749 | inc(YChange, TwoASquare) 750 | end; 751 | end 752 | else 753 | begin 754 | // done 755 | xo := x; 756 | yo := y; 757 | result := true; 758 | end; 759 | end; 760 | 761 | end; 762 | end; 763 | end; 764 | 765 | function QuadToStr(q : TQuad) : unicodestring; 766 | begin 767 | result := format('%d,%d %d,%d', [ q.v0, q.v1, q.v2, q.v3]); 768 | end; 769 | 770 | function isInteger(str : unicodestring) : boolean; 771 | var 772 | i : integer; 773 | begin 774 | for i := 1 to str.length do 775 | if not between(str[i], '0', '9') then 776 | exit(false); 777 | result := true; 778 | end; 779 | 780 | function StrToQuad(str : unicodestring) : TQuad; 781 | var 782 | l : integer; 783 | vals : TUnicodeStringArray; 784 | begin 785 | result.v0 := 64; 786 | result.v1 := 64; 787 | result.v2 := 64; 788 | result.v3 := 64; 789 | vals := str.Split([',',' ']); 790 | l := length(vals); 791 | if (l >= 1) and isInteger(vals[0]) then result.v0 := strtoint(vals[0]); 792 | if (l >= 2) and isInteger(vals[1]) then result.v1 := strtoint(vals[1]); 793 | if (l >= 3) and isInteger(vals[2]) then result.v2 := strtoint(vals[2]); 794 | if (l >= 4) and isInteger(vals[3]) then result.v3 := strtoint(vals[3]); 795 | setlength(vals,0); 796 | end; 797 | 798 | procedure SetFormQuad(f : TForm; q : TQuad); 799 | begin 800 | if q.v0 < 0 then q.v0 := 0; 801 | if q.v1 < 0 then q.v1 := 0; 802 | if q.v0 > Screen.Width then q.v0 := 0; 803 | if q.v1 > Screen.Height then q.v1 := 0; 804 | 805 | f.Left := q.v0; 806 | f.Top := q.v1; 807 | if q.v2 > 0 then 808 | begin 809 | f.Width := q.v2; 810 | f.Height := q.v3; 811 | end; 812 | end; 813 | 814 | function GetFormQuad(f : TForm) : TQuad; 815 | begin 816 | result.v0 := f.RestoredLeft; 817 | result.v1 := f.RestoredTop; 818 | result.v2 := f.RestoredWidth; 819 | result.v3 := f.RestoredHeight; 820 | end; 821 | 822 | function CharsToStr(src : array of char; len : integer) : unicodestring; 823 | var 824 | i : integer; 825 | begin 826 | result := ''; 827 | len := length(src); 828 | for i := 0 to len - 1 do 829 | begin 830 | if src[i] = #0 then 831 | break; 832 | result += src[i]; 833 | end; 834 | end; 835 | 836 | function CharsToStr(src : array of byte; len : integer) : unicodestring; 837 | var 838 | i : integer; 839 | begin 840 | result := ''; 841 | len := length(src); 842 | for i := 0 to len - 1 do 843 | begin 844 | if src[i] = 0 then 845 | break; 846 | result += char(src[i]); 847 | end; 848 | end; 849 | 850 | procedure DrawDashLine(cnv : TCanvas; x1, y1, x2, y2 : integer; clr1, clr2 : TColor); 851 | begin 852 | cnv.Brush.Style := bsClear; 853 | cnv.Pen.Color := clr1; 854 | cnv.Pen.Style := psSolid; 855 | cnv.Line(x1, y1, x2, y2); 856 | cnv.Brush.Style := bsClear; 857 | cnv.Pen.Color := clr2; 858 | cnv.Pen.Style := psDot; 859 | cnv.Line(x1, y1, x2, y2); 860 | end; 861 | 862 | procedure DrawDashRect(cnv : TCanvas; rect : TRect; clr1, clr2 : TColor); 863 | begin 864 | cnv.Brush.Style := bsClear; 865 | cnv.Pen.Color := clr1; 866 | cnv.Pen.Style := psSolid; 867 | cnv.Rectangle(rect); 868 | cnv.Brush.Style := bsClear; 869 | cnv.Pen.Color := clr2; 870 | cnv.Pen.Style := psDot; 871 | cnv.Rectangle(rect); 872 | end; 873 | 874 | procedure DrawDashRect(cnv : TCanvas; x1, y1, x2, y2 : integer; clr1, clr2 : TColor); 875 | begin 876 | cnv.Brush.Style := bsClear; 877 | cnv.Pen.Color := clr1; 878 | cnv.Pen.Style := psSolid; 879 | cnv.Rectangle(x1, y1, x2, y2); 880 | cnv.Brush.Style := bsClear; 881 | cnv.Pen.Color := clr2; 882 | cnv.Pen.Style := psDot; 883 | cnv.Rectangle(x1, y1, x2, y2); 884 | end; 885 | 886 | procedure DrawStretchedBitmap(cnv : TCanvas; r : TRect; bmp : TBGRABitmap); 887 | var 888 | tmpbmp : TBGRABitmap; 889 | begin 890 | tmpbmp := bmp.Resample(r.Width, r.Height, rmSimpleStretch) as TBGRABitmap; 891 | tmpbmp.Draw(cnv, r.left, r.top); 892 | tmpbmp.free; 893 | end; 894 | 895 | procedure Draw3DRect(cnv : TCanvas; rect : TRect; sunk : boolean); 896 | begin 897 | Draw3DRect(cnv, rect.Left, rect.Top, rect.Right, rect.Bottom, sunk); 898 | end; 899 | 900 | procedure Draw3DRect(cnv : TCanvas; x1, y1, x2, y2 : integer; sunk : boolean); 901 | var 902 | c1, c2 : TBGRAPixel; 903 | bmp : TBGRABitmap; 904 | w, h : integer; 905 | begin 906 | w := x2 - x1; 907 | h := y2 - y1; 908 | 909 | bmp := TBGRABitmap.Create(w, h, BGRAPixelTransparent); 910 | 911 | if sunk then 912 | begin 913 | c1 := BGRA(0, 0, 0, 192); 914 | c2 := BGRA(255, 255, 255, 192); 915 | end 916 | else 917 | begin 918 | c1 := BGRA(255, 255, 255, 192); 919 | c2 := BGRA(0, 0, 0, 192); 920 | end; 921 | 922 | bmp.DrawLine(0, h - 2, 0, 0, c1, true, dmSet); 923 | bmp.DrawLine(0, 0, w - 2, 0, c1, true, dmSet); 924 | bmp.DrawLine(1, h - 1, w - 1, h - 1, c2, true, dmSet); 925 | bmp.DrawLine(w - 1, h - 1, w - 1, 1, c2, true, dmSet); 926 | 927 | cnv.Draw(x1, y1, bmp.Bitmap); 928 | bmp.Free; 929 | end; 930 | 931 | end. 932 | 933 | -------------------------------------------------------------------------------- /work/MicroKnightPlus_v1.0.raw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/MicroKnightPlus_v1.0.raw -------------------------------------------------------------------------------- /work/MicroKnight_v1.0.raw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/MicroKnight_v1.0.raw -------------------------------------------------------------------------------- /work/P0T-NOoDLE_v1.0.raw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/P0T-NOoDLE_v1.0.raw -------------------------------------------------------------------------------- /work/TopazPlus_a1200_v1.0.raw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/TopazPlus_a1200_v1.0.raw -------------------------------------------------------------------------------- /work/TopazPlus_a500_v1.0.raw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/TopazPlus_a500_v1.0.raw -------------------------------------------------------------------------------- /work/Topaz_a1200_v1.0.raw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/Topaz_a1200_v1.0.raw -------------------------------------------------------------------------------- /work/Topaz_a500_v1.0.raw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/Topaz_a500_v1.0.raw -------------------------------------------------------------------------------- /work/c0.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c0.cur -------------------------------------------------------------------------------- /work/c0.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c0.png -------------------------------------------------------------------------------- /work/c1.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c1.cur -------------------------------------------------------------------------------- /work/c1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c1.png -------------------------------------------------------------------------------- /work/c2.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c2.cur -------------------------------------------------------------------------------- /work/c2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c2.png -------------------------------------------------------------------------------- /work/c3.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c3.cur -------------------------------------------------------------------------------- /work/c3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c3.png -------------------------------------------------------------------------------- /work/c4.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c4.cur -------------------------------------------------------------------------------- /work/c4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c4.png -------------------------------------------------------------------------------- /work/c5.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c5.cur -------------------------------------------------------------------------------- /work/c5.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c5.png -------------------------------------------------------------------------------- /work/c6.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c6.cur -------------------------------------------------------------------------------- /work/c6.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c6.png -------------------------------------------------------------------------------- /work/c7.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c7.cur -------------------------------------------------------------------------------- /work/c7.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c7.png -------------------------------------------------------------------------------- /work/c8.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c8.cur -------------------------------------------------------------------------------- /work/c8.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c8.png -------------------------------------------------------------------------------- /work/c9.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c9.cur -------------------------------------------------------------------------------- /work/c9.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/c9.png -------------------------------------------------------------------------------- /work/cursors.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/cursors.png -------------------------------------------------------------------------------- /work/grayicons.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/grayicons.png -------------------------------------------------------------------------------- /work/icons.cdr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/icons.cdr -------------------------------------------------------------------------------- /work/icons.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/icons.png -------------------------------------------------------------------------------- /work/mO'sOul_v1.0.raw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/codewar65/VTXEdit/ddd31be618071df1ec668d99b1812a79179846b3/work/mO'sOul_v1.0.raw --------------------------------------------------------------------------------