Apophysis-AV/ColorMap/cmap.pas

516 lines
14 KiB
ObjectPascal
Raw Normal View History

2022-03-08 12:25:51 -05:00
{
Apophysis Copyright (C) 2001-2004 Mark Townsend
Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov
Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov
Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov
Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne
Apophysis AV "Phoenix Edition" Copyright (C) 2021-2022 Alice V. Koryagina
2022-03-08 12:25:51 -05:00
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
unit Cmap;
interface
uses cmapdata, SysUtils, Classes, Windows;
// AV: moved following from Main unit and deleted all duplicates
const
PixelCountMax = 32768;
2022-03-08 12:25:51 -05:00
type
pRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..PixelCountMax - 1] of TRGBTriple;
2022-03-08 12:25:51 -05:00
TColorMap = array[0..255, 0..3] of integer;
EPaletteInvalid = class(Exception); // AV: renamed due to name-space conflicts
2022-03-08 12:25:51 -05:00
const
RANDOMCMAP = -1;
NRCMAPS = NMAPS + 1; //704;
2022-03-08 12:25:51 -05:00
procedure GetCmap(var Index: integer; const hue_rotation: double; out cmap: TColorMap);
procedure GetCmapName(var Index: integer; out Name: string);
procedure rgb2hsv(const rgb: array of double; out hsv: array of double);
procedure hsv2rgb(const hsv: array of double; out rgb: array of double);
function GetGradient(FileName, Entry: string): string;
function GetVal(token: string): string; // AV: make public
function ReplaceTabs(str: string): string; // AV: make public
function CreatePalette(strng: string): TColorMap; // AV: moved from RndFlame
2022-03-08 12:25:51 -05:00
function GetPalette(strng: string; var Palette: TColorMap): boolean;
procedure GetTokens(s: string; var mlist: TStringList);
procedure HSVBlend(a, b: integer; var Palette: TColorMap); // AV
procedure RGBBlend(a, b: integer; var Palette: TColorMap);
procedure Brighten(const n: byte; var r, g, b: byte); // AV
implementation
uses
Math;
2022-03-08 12:25:51 -05:00
procedure rgb2hsv(const rgb: array of double; out hsv: array of double);
var
maxval, minval: double;
del: double;
begin
Maxval := Max(rgb[0], Max(rgb[1], rgb[2]));
Minval := Min(rgb[0], Min(rgb[1], rgb[2]));
hsv[2] := maxval; // v
if (Maxval > 0) and (maxval <> minval) then begin
del := maxval - minval;
hsv[1] := del / Maxval; //s
hsv[0] := 0;
if (rgb[0] > rgb[1]) and (rgb[0] > rgb[2]) then begin
hsv[0] := (rgb[1] - rgb[2]) / del;
end else if (rgb[1] > rgb[2]) then begin
hsv[0] := 2 + (rgb[2] - rgb[0]) / del;
end else begin
hsv[0] := 4 + (rgb[0] - rgb[1]) / del;
end;
if hsv[0] < 0 then
hsv[0] := hsv[0] + 6;
end else begin
hsv[0] := 0;
hsv[1] := 0;
end;
end;
procedure hsv2rgb(const hsv: array of double; out rgb: array of double);
var
j: integer;
f, p, q, t, v: double;
begin
try
j := floor(hsv[0]);
f := hsv[0] - j;
v := hsv[2];
p := hsv[2] * (1 - hsv[1]);
q := hsv[2] * (1 - hsv[1] * f);
t := hsv[2] * (1 - hsv[1] * (1 - f));
case j of
0: begin rgb[0] := v; rgb[1] := t; rgb[2] := p; end;
1: begin rgb[0] := q; rgb[1] := v; rgb[2] := p; end;
2: begin rgb[0] := p; rgb[1] := v; rgb[2] := t; end;
3: begin rgb[0] := p; rgb[1] := q; rgb[2] := v; end;
4: begin rgb[0] := t; rgb[1] := p; rgb[2] := v; end;
5: begin rgb[0] := v; rgb[1] := p; rgb[2] := q; end;
end;
except on EMathError do
begin
rgb[0] := 0;
rgb[1] := 0;
rgb[2] := 0;
end;
2022-03-08 12:25:51 -05:00
end;
end;
procedure GetCmap(var Index: integer; const hue_rotation: double; out cmap: TColorMap);
var
i: Integer;
rgb: array[0..2] of double;
hsv: array[0..2] of double;
begin
if Index = RANDOMCMAP then
Index := Random(NRCMAPS);
if (Index < 0) or (Index >= NRCMAPS) then
Index := 0;
for i := 0 to 255 do begin
rgb[0] := cmaps[Index][i][0] / 255.0;
rgb[1] := cmaps[Index][i][1] / 255.0;
rgb[2] := cmaps[Index][i][2] / 255.0;
rgb2hsv(rgb, hsv);
hsv[0] := hsv[0] + hue_rotation * 6;
hsv2rgb(hsv, rgb);
cmap[i][0] := Round(rgb[0] * 255);
cmap[i][1] := Round(rgb[1] * 255);
cmap[i][2] := Round(rgb[2] * 255);
end;
end;
procedure GetCmapName(var Index: integer; out Name: string);
begin
if Index = RANDOMCMAP then
Index := Random(NRCMAPS);
if (Index < 0) or (Index >= NRCMAPS) then
Index := 0;
Name := CMapNames[Index];
end;
procedure RGBBlend(a, b: integer; var Palette: TColorMap);
{ Linear blend between to indices of a palette }
var
c, v: real;
vrange, range: real;
i: integer;
begin
if a = b then
begin
Exit;
end;
range := b - a;
vrange := Palette[b mod 256][0] - Palette[a mod 256][0];
c := Palette[a mod 256][0];
v := vrange / range;
for i := (a + 1) to (b - 1) do
begin
c := c + v;
Palette[i mod 256][0] := Round(c);
end;
vrange := Palette[b mod 256][1] - Palette[a mod 256][1];
c := Palette[a mod 256][1];
v := vrange / range;
for i := a + 1 to b - 1 do
begin
c := c + v;
Palette[i mod 256][1] := Round(c);
end;
vrange := Palette[b mod 256][2] - Palette[a mod 256][2];
c := Palette[a mod 256][2];
v := vrange / range;
for i := a + 1 to b - 1 do
begin
c := c + v;
Palette[i mod 256][2] := Round(c);
end;
end;
procedure HSVBlend(a, b: integer; var Palette: TColorMap);
{ AV: Linear HSV interpolation}
var i, range: integer;
rgb, hsv, rgb1, hsv1, rgb2, hsv2: array [0..2] of double;
function lerp(range, b, i: integer; p1, p2: double): double;
var k: double;
begin
k := (b - i)/range;
Result := k * p1 + (1 - k) * p2;
end;
begin
if a = b then Exit;
range := b - a;
for i := 0 to 2 do begin
rgb1[i] := double(Palette[a][i]);
rgb2[i] := double(Palette[b][i]);
end;
rgb2hsv(rgb1, hsv1);
rgb2hsv(rgb2, hsv2);
for i := (a + 1) to (b - 1) do
begin
hsv[0] := lerp(range, b, i, hsv1[0], hsv2[0]);
hsv[1] := lerp(range, b, i, hsv1[1], hsv2[1]);
hsv[2] := lerp(range, b, i, hsv1[2], hsv2[2]);
hsv2rgb(hsv, rgb);
Palette[i][0] := Round(rgb[0]);
Palette[i][1] := Round(rgb[1]);
Palette[i][2] := Round(rgb[2]);
end;
end;
procedure Brighten(const n: byte; var r, g, b: byte);
var rgb, hsv: array [0..2] of double;
begin
rgb[0] := double(r);
rgb[1] := double(g);
rgb[2] := double(b);
rgb2hsv(rgb, hsv);
hsv[2] := hsv[2] + n;
// if (hsv[2] < 0) then hsv[2] := 0
// else if (hsv[2] > 255) then hsv[2] := 255;
hsv2rgb(hsv, rgb);
r := Round(rgb[0]);
g := Round(rgb[1]);
b := Round(rgb[2]);
end;
function GetVal(token: string): string;
var
p: integer;
begin
p := Pos('=', token);
Delete(Token, 1, p);
Result := Token;
end;
function ReplaceTabs(str: string): string;
{Changes tab characters in a string to spaces}
var
i: integer;
begin
for i := 1 to Length(str) do
begin
if str[i] = #9 then
begin
Delete(str, i, 1);
Insert(#32, str, i);
end;
end;
Result := str;
end;
procedure GetTokens(s: string; var mlist: TStringList);
var
test, token: string;
begin
mlist.clear;
test := s;
while (Length(Test) > 0) do
begin
while (Length(Test) > 0) and CharInSet(test[1],[#32]) do
Delete(test, 1, 1);
if (Length(Test) = 0) then
exit;
token := '';
while (Length(Test) > 0) and (not CharInSet(test[1],[#32])) do
begin
token := token + test[1];
Delete(test, 1, 1);
end;
mlist.add(token);
end;
end;
function CreatePalette(strng: string): TColorMap; // AV: moved from RndFlame
{ Loads a palette from a gradient string }
var
Strings: TStringList;
index, i: integer;
Tokens: TStringList;
Indices, Colors: TStringList;
a, b: integer;
begin
Strings := TStringList.Create;
Tokens := TStringList.Create;
Indices := TStringList.Create;
Colors := TStringList.Create;
try
try
Strings.Text := strng;
if Pos('}', Strings.Text) = 0 then raise EPaletteInvalid.Create('No closing brace');
if Pos('{', Strings[0]) = 0 then raise EPaletteInvalid.Create('No opening brace.');
GetTokens(ReplaceTabs(strings.text), tokens);
Tokens.Text := Trim(Tokens.text);
i := 0;
while (Pos('}', Tokens[i]) = 0) and (Pos('opacity:', Lowercase(Tokens[i])) = 0) do
begin
if Pos('index=', LowerCase(Tokens[i])) <> 0 then
Indices.Add(GetVal(Tokens[i]))
else if Pos('color=', LowerCase(Tokens[i])) <> 0 then
Colors.Add(GetVal(Tokens[i]));
inc(i)
end;
for i := 0 to 255 do
begin
Result[i][0] := 0;
Result[i][1] := 0;
Result[i][2] := 0;
end;
if Indices.Count = 0 then raise EPaletteInvalid.Create('No color info');
for i := 0 to Indices.Count - 1 do
begin
try
index := StrToInt(Indices[i]);
while index < 0 do inc(index, 400);
index := Round(Index * (255 / 399));
indices[i] := IntToStr(index);
assert(index >= 0);
assert(index < 256);
a := StrToInt(Colors[i]); // AV: added precalc
Result[index][0] := a mod 256;
Result[index][1] := trunc(a / 256) mod 256;
Result[index][2] := trunc(a / 65536);
except
end;
end;
i := 1;
repeat
a := StrToInt(Trim(Indices[i - 1]));
b := StrToInt(Trim(Indices[i]));
RGBBlend(a, b, Result);
inc(i);
until i = Indices.Count;
if (Indices[0] <> '0') or (Indices[Indices.Count - 1] <> '255') then
begin
a := StrToInt(Trim(Indices[Indices.Count - 1]));
b := StrToInt(Trim(Indices[0])) + 256;
RGBBlend(a, b, Result);
end;
except on EPaletteInvalid do
begin
//
end;
end;
finally
Tokens.Free;
Strings.Free;
Indices.Free;
Colors.Free;
end;
end;
2022-03-08 12:25:51 -05:00
function GetPalette(strng: string; var Palette: TColorMap): boolean;
{ Loads a palette from a gradient string }
var
Strings: TStringList;
index, i: integer;
Tokens: TStringList;
Indices, Colors: TStringList;
a, b: integer;
begin
GetPalette := True;
Strings := TStringList.Create;
Tokens := TStringList.Create;
Indices := TStringList.Create;
Colors := TStringList.Create;
try
try
Strings.Text := strng;
if Pos('}', Strings.Text) = 0 then
raise EPaletteInvalid.Create('No closing brace');
if Pos('{', Strings[0]) = 0 then
raise EPaletteInvalid.Create('No opening brace.');
2022-03-08 12:25:51 -05:00
GetTokens(ReplaceTabs(Strings.Text), Tokens);
i := 0;
while (Pos('}', Tokens[i]) = 0) and (Pos('opacity:', Lowercase(Tokens[i])) = 0) do
begin
if Pos('index=', LowerCase(Tokens[i])) <> 0 then
Indices.Add(GetVal(Tokens[i]))
else if Pos('color=', LowerCase(Tokens[i])) <> 0 then
Colors.Add(GetVal(Tokens[i]));
inc(i)
end;
for i := 0 to 255 do
begin
Palette[i][0] := 0;
Palette[i][1] := 0;
Palette[i][2] := 0;
end;
if Indices.Count = 0 then
raise EPaletteInvalid.Create('No color info');
2022-03-08 12:25:51 -05:00
for i := 0 to Indices.Count - 1 do
begin
try
index := StrToInt(Indices[i]);
while index < 0 do inc(index, 400);
index := Round(Index * (255 / 399));
indices[i] := IntToStr(index);
assert(index >= 0);
assert(index < 256);
2022-03-08 12:25:51 -05:00
Palette[index][0] := StrToInt(Colors[i]) mod 256;
Palette[index][1] := trunc(StrToInt(Colors[i]) / 256) mod 256;
Palette[index][2] := trunc(StrToInt(Colors[i]) / 65536);
except
end;
end;
i := 1;
repeat
a := StrToInt(Indices[i - 1]);
b := StrToInt(Indices[i]);
RGBBlend(a, b, Palette);
inc(i);
until i = Indices.Count;
if (Indices[0] <> '0') or (Indices[Indices.Count - 1] <> '255') then
begin
a := StrToInt(Indices[Indices.Count - 1]);
b := StrToInt(Indices[0]) + 256;
RGBBlend(a, b, Palette);
end;
except on EPaletteInvalid do
2022-03-08 12:25:51 -05:00
begin
Result := False;
end;
end;
finally
Tokens.Free;
Strings.Free;
Indices.Free;
Colors.Free;
end;
end;
function GetGradient(FileName, Entry: string): string;
var
FileStrings: TStringList;
GradStrings: TStringList;
i: integer;
begin
FileStrings := TStringList.Create;
GradStrings := TStringList.Create;
try
try
FileStrings.LoadFromFile(FileName);
for i := 0 to FileStrings.count - 1 do
if Pos(Entry + ' ', Trim(FileStrings[i])) = 1 then break;
GradStrings.Add(FileStrings[i]);
repeat
inc(i);
GradStrings.Add(FileStrings[i]);
until Pos('}', FileStrings[i]) <> 0;
GetGradient := GradStrings.Text;
except on exception do
Result := '';
end;
finally
GradStrings.Free;
FileStrings.Free;
end;
end;
function LoadGradient(FileName, Entry: string; var gString: string; var Pal: TColorMap): boolean;
var
FileStrings: TStringList;
GradStrings: TStringList;
i: integer;
begin
FileStrings := TStringList.Create;
GradStrings := TStringList.Create;
try
try
FileStrings.LoadFromFile(FileName);
for i := 0 to FileStrings.count - 1 do
if Pos(Entry + ' ', Trim(FileStrings[i])) = 1 then break;
GradStrings.Add(FileStrings[i]);
repeat
inc(i);
GradStrings.Add(FileStrings[i]);
until Pos('}', FileStrings[i]) <> 0;
gString := GradStrings.Text;
Result := GetPalette(GradStrings.Text, Pal);
except on exception do
Result := False;
end;
finally
GradStrings.Free;
FileStrings.Free;
end;
end;
end.