Initial commit

ColorMap/GradientHlpr.pas

@@ -0,0 +1,190 @@
+{
+     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 Alice V. Koryagina
+
+     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 GradientHlpr;
+
+interface
+
+uses
+  windows, Graphics, Cmap;
+
+const
+  PixelCountMax = 32768;
+
+type
+  pRGBTripleArray = ^TRGBTripleArray;
+  TRGBTripleArray = array[0..PixelCountMax - 1] of TRGBTriple;
+
+type
+  TGradientHelper = class
+  private
+    procedure RGBBlend(a, b: integer; var Palette: TColorMap);
+  public
+    function GetGradientBitmap(Index: integer; const hue_rotation: double): TBitmap;
+    function RandomGradient: TColorMap;
+  end;
+
+var
+  GradientHelper: TGradientHelper;
+
+implementation
+
+uses
+  Global;
+
+{ TGradientHelper }
+
+function TGradientHelper.GetGradientBitmap(Index: integer; const hue_rotation: double): TBitmap;
+var
+  BitMap: TBitMap;
+  i, j: integer;
+  Row: pRGBTripleArray;
+  pal: TColorMap;
+begin
+  GetCMap(index, hue_rotation, pal);
+
+  BitMap := TBitMap.create;
+  Bitmap.PixelFormat := pf24bit;
+  BitMap.Width := 256;
+  BitMap.Height := 2;
+
+  for j := 0 to Bitmap.Height - 1 do begin
+    Row := Bitmap.Scanline[j];
+    for i := 0 to Bitmap.Width - 1 do begin
+      Row[i].rgbtRed := Pal[i][0];
+      Row[i].rgbtGreen := Pal[i][1];
+      Row[i].rgbtBlue := Pal[i][2];
+    end
+  end;
+
+  Result := BitMap;
+end;
+
+///////////////////////////////////////////////////////////////////////////////
+function TGradientHelper.RandomGradient: TColorMap;
+var
+  a, b, i, n, nodes: integer;
+  c: byte;
+  rgb: array[0..2] of double;
+  hsv: array[0..2] of double;
+  pal: TColorMap;
+begin
+  rgb[0] := 0;
+  rgb[1] := 0;
+  rgb[2] := 0;
+
+  inc(MainSeed);
+  RandSeed := Mainseed;
+  nodes := random((MaxNodes - 1) - (MinNodes - 2)) + (MinNodes - 1);
+  n := 256 div nodes;
+  b := 0;
+  hsv[0] := 0.01 * (random(MaxHue - (MinHue - 1)) + MinHue);
+  hsv[1] := 0.01 * (random(MaxSat - (MinSat - 1)) + MinSat);
+  hsv[2] := 0.01 * (random(MaxLum - (MinLum - 1)) + MinLum);
+  hsv2rgb(hsv, rgb);
+  Pal[0][0] := Round(rgb[0] * 255);
+  Pal[0][1] := Round(rgb[1] * 255);
+  Pal[0][2] := Round(rgb[2] * 255);
+  c := 0;
+  repeat
+    a := b;
+    if EqualStripes then
+      b := b + n
+    else begin
+      inc(c);
+      if c = nodes then
+        b := 255
+      else begin
+        i := Random(256 - b);
+        b := b + i;
+      end;
+    end;
+    hsv[0] := 0.01 * (random(MaxHue - (MinHue - 1)) + MinHue);
+    hsv[1] := 0.01 * (random(MaxSat - (MinSat - 1)) + MinSat);
+    hsv[2] := 0.01 * (random(MaxLum - (MinLum - 1)) + MinLum);
+    hsv2rgb(hsv, rgb);
+    if b > 255 then b := 255;
+    Pal[b][0] := Round(rgb[0] * 255);
+    Pal[b][1] := Round(rgb[1] * 255);
+    Pal[b][2] := Round(rgb[2] * 255);
+    case randColorBlend of
+    0:  RGBBlend(a, b, pal);
+    1:  HSVBlend(a, b, pal);
+    else
+      for i := a + 1 to b - 1 do
+      begin
+        Pal[i][0] := Round(rgb[0] * 255);
+        Pal[i][1] := Round(rgb[1] * 255);
+        Pal[i][2] := Round(rgb[2] * 255);
+      end;
+    end;
+  until b = 255;
+  Result := Pal;
+end;
+
+///////////////////////////////////////////////////////////////////////////////
+procedure TGradientHelper.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;
+
+///////////////////////////////////////////////////////////////////////////////
+initialization
+  GradientHelper := TGradientHelper.create;
+finalization
+  GradientHelper.Free;
+end.

ColorMap/cmap.pas

@@ -0,0 +1,426 @@
+{
+     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 Alice V. Koryagina
+
+     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 sysutils, classes;
+
+type
+  TColorMap = array[0..255, 0..3] of integer;
+
+type
+  EFormatInvalid = class(Exception);
+
+const
+  RANDOMCMAP = -1;
+  NRCMAPS = 704;
+
+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 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
+  cmapdata, Math;
+
+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
+//    rgb[0] := 0;
+//    rgb[1] := 0;
+//    rgb[2] := 0;
+
+    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
+  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 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 EFormatInvalid.Create('No closing brace');
+      if Pos('{', Strings[0]) = 0 then raise EFormatInvalid.Create('No opening brace.');
+      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 EFormatInvalid.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);
+        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 EFormatInvalid do
+      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.
+