initial commit moved from svn
This commit is contained in:
fatalerrors
278
ucommon.pas
Normal file
278
ucommon.pas
Normal file
@@ -0,0 +1,278 @@
|
||||
{
|
||||
********************************************************************************
|
||||
|
||||
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.
|
||||
|
||||
Reference in New Issue
Block a user