yapetavi/ucommon.pas

{
********************************************************************************

YaPeTaVi - Yet another Periodic Table Viewer
Copyright (C) 2018 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.

All rights reserved.
http://www.geoffray-levasseur.org/

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 3 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., 59 Temple
Place - Suite 330, Boston, MA  02111-1307, USA.

********************************************************************************

Description:
  Common specific YaPeTaVi code

}
unit uCommon;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Graphics, ComCtrls;

const
  ElemNumber = 112;

type
  TRange = array[1..ElemNumber] of Boolean;

  //Get a color from the given value according min and max levels
  function GetGradientColor(const Min, Max, Value: integer;
    const MinCol, MaxCol: TColor): TColor;
  function GetGradientColor(const Min, Max, Value: Double;
    const MinCol, MaxCol: TColor): TColor;

  //Convert ListView index to an element list index
  function GetListIndexFromView(var LV: TListView; const I: integer): integer;

  //setup a range with the given string
  function SetRange(S: string): Boolean;

  //setup the range to include all possible values
  procedure FullRange;

  //look for picture in different possible place and with different possible format
  function GetPicRessource(Name: string): string;

implementation

uses
  uDebug, uConst, uUtils;

function GetGradientColor(const Min, Max, Value: integer;
  const MinCol, MaxCol: TColor): TColor;
var
  MinR, MinG, MinB, MaxR, MaxG, MaxB: byte;
begin
  MinR := Red(ColorToRGB(MinCol));
  MinG := Green(ColorToRGB(MinCol));
  MinB := Blue(ColorToRGB(MinCol));
  MaxR := Red(ColorToRGB(MaxCol));
  MaxG := Green(ColorToRGB(MaxCol));
  MaxB := Blue(ColorToRGB(MaxCol));
  Result := RGBToColor(
    Round((MaxR - MinR) * ((Value - Min) / (Max - Min)) + MinR),
    Round((MaxG - MinG) * ((Value - Min) / (Max - Min)) + MinG),
    Round((MaxB - MinB) * ((Value - Min) / (Max - Min)) + MinB));
end;

function GetGradientColor(const Min, Max, Value: Double;
  const MinCol, MaxCol: TColor): TColor;
var
  MinR, MinG, MinB, MaxR, MaxG, MaxB: byte;
begin
  MinR := Red(ColorToRGB(MinCol));
  MinG := Green(ColorToRGB(MinCol));
  MinB := Blue(ColorToRGB(MinCol));
  MaxR := Red(ColorToRGB(MaxCol));
  MaxG := Green(ColorToRGB(MaxCol));
  MaxB := Blue(ColorToRGB(MaxCol));
  Result := RGBToColor(
    Round((MaxR - MinR) * ((Value - Min) / (Max - Min))) + MinR,
    Round((MaxG - MinG) * ((Value - Min) / (Max - Min))) + MinG,
    Round((MaxB - MinB) * ((Value - Min) / (Max - Min))) + MinB);
end;

function SetRange(S: string): Boolean;
{$warning Add a Range as var parameter, then change all the calls}
{$warning Improve in order to use the error system}
var
  TmpRange: TRange;

  procedure InitRange(var R: TRange);
  var
    I: integer;
  begin
    for I := 1 to ElemNumber do
       R[I] := False;
  end;

  function ApplyRange(S: string): Boolean;
  var
    I: integer;
    J: integer;
    N1, N2: integer;
    Tmp1, Tmp2: string;
  begin
    PrintLnDbg('-- Applying new range: "' + S + '"...', vlLow);
    Inc(DebugLevel);
    Tmp1 := '';
    Tmp2 := '';
    I := 1;
    while S[I] <> ';' do  //find the first number
    begin
      while S[I] in ['0'..'9'] do
      begin
        Tmp1 := Tmp1 + S[I];
        Inc(I);
      end {while};
      if Length(Tmp1) < 1 then
      begin
        Result := False; //syntax error
        PrintLnDbg('*** uUtils.ApplyRange: ERROR: Range error at pos #' +
          IntToStr(I), vlLow);
        Exit;
      end {if};
      while S[I] = ' ' do Inc(I); //eliminate space
      if S[I] = ';' then //single number
      begin
        TmpRange[StrToInt(Tmp1)] := True;
        if I < Length(S) then
          Result := ApplyRange(Copy(S, I + 1, Length(S) - I));
      end else
      if S[I] = '-' then // full range
      begin
        Inc(I);
        while S[I] in ['0'..'9'] do  //find second number
        begin
          Tmp2 := Tmp2 + S[I];
          Inc(I);
        end {while};
        if Length(Tmp2) < 1 then
        begin
          Result := False; //syntax error
          PrintLnDbg('*** uUtils.ApplyRange: ERROR: Range error at pos #' +
            IntToStr(I), vlLow);
          Exit;
        end {if};
        if StrToInt(Tmp1) >= StrToInt(Tmp2) then
          for J := StrToInt(Tmp2) to StrToInt(Tmp1) do
            TmpRange[J] := True
        else for J := StrToInt(Tmp1) to StrToInt(Tmp2) do
          TmpRange[J] := True;
        if I < Length(S) then
          Result := ApplyRange(Copy(S, I + 1, Length(S) - I));
        if S[I] <> ';' then
        begin
          Result := False; //syntax error
          PrintLnDbg('   *** uUtils.ApplyRange: ERROR: Range error at pos #' +
            IntToStr(I), vlLow);
          Exit;
        end {if};
      end else
      begin
        Result := False; //syntax error
          PrintLnDbg('*** uUtils.ApplyRange: ERROR: Range error at pos #' +
            IntToStr(I), vlLow);
        Exit;
      end {if};
    end;
    Dec(DebugLevel);
    PrintLnDbg('-- Ok', vlLow);
  end;

begin
  InitRange(TmpRange);
  S := Trim(S);
  if Length(S) = 0 then
    S := '1-' + IntToStr(ElemNumber) + ';';
  if S[Length(S)] <> ';' then
    S := S + ';';
  Result := ApplyRange(S);
  if Result then
  begin
    InitRange(RangeArray);
    RangeArray := TmpRange;
  end;
end;

procedure FullRange;
var
  I: integer;
begin
  for I := 1 to ElemNumber do
    RangeArray[I] := True;
end;

function GetListIndexFromView(var LV: TListView; const I: integer): integer;
var
  N: integer;
begin
//  Writeln('Get list index from view... I = ', I, ' for ',
//    LV.Items[I].SubItems[0]);
  for N := 1 to ElemNumber do
    if (ElementsList.Elements[N].ShortName = LV.Items[I].SubItems[0]) then
    begin
      Result := N;
      Exit;
    end;
end;

//return the full path of a picture ressource:
//- check it in users path (for personnal datas), then application prefix,
//  then (on unix-like) on FHS
//- check for .jpg, .jpeg, .png, .gif
//CAREFULL: on unix like this is case sensitive
function GetPicRessource(Name: string): string;
var
  Err, APos: integer;
  S: string;

  function TestExt(Path, Name: string): string;
  begin
    if Path[Length(Path)] <> DirectorySeparator then
      Path := Path + DirectorySeparator;
    if not FileExists(Path + Name + '.jpg') then
      if not FileExists(Path+ Name + '.jpeg') then
        if not FileExists(Path + Name + '.png') then
          if not FileExists(Path + Name + '.gif') then
            Result := ''
          else Result := Path + Name + '.gif'
        else Result := Path + Name + '.png'
      else Result := Path + Name + '.jpeg'
    else Result := Path + Name + '.jpg';
    PrintLnDbg('Path ' + Path + ' checked for pictures with result: ' + Result,
      vlHigh);
  end;

begin
  S := TestExt(sPicPath, Name);
  if S = '' then
  begin
    S := TestExt(GetProgramPrefix + '../pics', Name);
    if S = '' then
    {$ifdef UNIX}
    begin
      S := TestExt('/usr/share/yapetavi/pics/', Name);
      if S = '' then
      begin
        S := TestExt('/usr/local/share/yapetavi/pics/', Name);
        if S = '' then
    {$endif}
          PrintLnDbg('E Can''t find picture for "' + Name + '"!', vlLow);
    {$ifdef UNIX}
      end;
    end;
    {$endif}
  end;
  if S <> '' then
    FormatFileName(S, Result);
end;

end.