unit AnnotationCategories;
{
[AnnotationCategories] [1.3]
Delphi 2005
September 2007

LICENSE

The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
"http://www.mozilla.org/MPL/"

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is "[AnnotationCategories.pas]".

The Initial Developer of the Original Code is Martin Holmes (Victoria,
BC, Canada, "http://www.mholmes.com/"). Copyright (C) 2006-2007 Martin Holmes 
and the University of Victoria Computing and Media Centre. The code was 
co-developed for university and personal projects, and rights are shared
by Martin Holmes and the University of Victoria. All Rights Reserved.
}

{
Written by Martin Holmes, Winter 2006 - Fall 2007.

This unit contains classes for handling the list of categories to which
annotations in the Image Markup Tool can be assigned. An AnnCategory has a
name (of form xml:id, and unique in any given AnnCategoryList), and display
details (currently shape and colour, but other info can easily be included.)

AnnCategories and  AnnCategoryLists can read and write themselves from and
to dom elements.

Dependencies:

XDOM_4_1 (Dieter Köhler)

}
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  XDOM_4_1, mdhGraphics, jclUnicode, XMLUtilities, IMTDocGlobals;



type
  TAnnCategory = class(TObject)
  private
    fColor: TColor;
    fShape: integer;
    fModified: Boolean;
    fID: WideString;
    fExplanation: WideString;
    fTranscriptional: Boolean;
    procedure SetColor(const Value: TColor);
    procedure SetShape(const Value: integer);
    function GetCSS: WideString;
    procedure SetCSS(const Value: WideString);
    function GetwsShape: WideString;
    procedure SetwsShape(const Value: WideString);
    procedure SetExplanation(const Value: WideString);
    procedure SetID(const Value: WideString);
    procedure SetTranscriptional(const Value: Boolean);
  public
    constructor Create;
    procedure WriteToDomElement(El: TDomElement; OwnerDoc: TDomDocument);
    procedure ReadFromDomElement(El: TDomElement);
  published
    property Color: TColor read fColor write SetColor default clBlue;
    property Shape: integer read FShape write SetShape default asSpiral;
    property wsShape: WideString read GetwsShape write SetwsShape;
    property Modified: Boolean read fModified write fModified default False;
    property Transcriptional: Boolean read fTranscriptional write SetTranscriptional default False;
    property CSS: WideString read GetCSS write SetCSS;
    property ID: WideString read fID write SetID;
    property Explanation: WideString read fExplanation write SetExplanation;
  end;

  type
    TAnnCatList = class(TList)
    private
      fModified: Boolean;
      function GetID(Index: integer): WideString;
      procedure SetID(Index: integer; const Value: WideString);
      function IDIsUnique(TheID: WideString; Index: integer): Boolean;
      function GetShape(Index: integer): integer;
      procedure SetShape(Index: integer; const Value: integer);
      function GetColor(Index: integer): TColor;
      procedure SetColor(Index: integer; const Value: TColor);
      procedure EnforceUniqueIDs;
      function GetExplanation(Index: integer): WideString;
      procedure SetExplanation(Index: integer; const Value: WideString);
      function GetTranscriptional(Index: integer): Boolean;
      procedure SetTranscriptional(Index: integer; const Value: Boolean);
    function GetModified: Boolean;
    procedure SetModified(const Value: Boolean);

    public
      function IndexInRange(Index: integer): Boolean;
      procedure WriteToEncodingDesc(EncDesc: TDomElement; OwnerDoc: TDomDocument);
      procedure ReadFromEncodingDesc(EncDesc: TDomElement);

      procedure Empty;

      function AddCategory(NewCatID: WideString): integer;
      function DeleteCategory(Index: integer): Boolean;
      function FindCategoryFromColorAndShape(TheColor: TColor; TheShape: integer; var CatID: WideString): integer;
      function FindCategoryNumFromID(CatID: WideString): integer;
      function GetShapeFromCatID(CatID: WideString): integer;
      function GetColorFromCatID(CatID: WideString): TColor;
      function GetExplanationFromCatID(CatID: WideString): WideString;
      function GetTranscriptionalFromCatID(CatID: WideString): Boolean;

      function SwapCategories(CatNum1, CatNum2: integer): Boolean;

      property ID[Index: integer]: WideString read GetID write SetID;
      property Shape[Index: integer]: integer read GetShape write SetShape;
      property Color[Index: integer]: TColor read GetColor write SetColor;
      property Explanation[Index: integer]: WideString read GetExplanation write SetExplanation;
      property Transcriptional[Index: integer]: Boolean read GetTranscriptional write SetTranscriptional;
    published
      property Modified: Boolean read GetModified write SetModified default False;
    end;

implementation

{ TAnnCategory }

procedure TAnnCategory.SetShape(const Value: integer);
begin
  if Value <> fShape then
    begin
      FShape := Value;
      Modified := True;
    end;
end;

procedure TAnnCategory.SetColor(const Value: TColor);
begin
  if Value <> fColor then
    begin
      FColor := Value;
      Modified := True;
    end;
end;

constructor TAnnCategory.Create;
begin
  inherited;
  ID := 'Category';
  Explanation := 'Explanation of this annotation category...';
  Modified := False;
  fColor := clBlue;
  fShape := asRectangle;
end;

function TAnnCategory.GetCSS: WideString;
begin
//More features may be added here later
  Result := WideString('color: ' + ColorToHTML(Color, True));
end;

procedure TAnnCategory.SetCSS(const Value: WideString);
var
Temp, InCSS: WideString;
i: integer;

  function ProcessRule(Rule: WideString): Boolean;//returns true if colour found
  var
  Selector, Value: WideString;
  ColonPos: integer;
  begin
    Result := False; //default
    Rule := Trim(Rule);
    ColonPos := Pos(WideString(':'), Rule);
    Selector := Trim(Copy(Rule, 1, ColonPos-1));
    Value := Trim(Copy(Rule, ColonPos+1, Length(Rule)-ColonPos));
//Add more blocks like the following as necessary
    if (Selector = 'color') then
      begin
        Color := WebColorToWinColorDef(Value, clBlue);
        Result := True;
      end;
  end;

begin
//We only need to read the color value right now, so this can be
//simple, but later we might want a full stylesheet parser component.
  InCSS := WideTrim(Value);
  Temp := '';
  if Length(InCSS) > 0 then
    begin
      for i := 1 to Length(InCSS) do
        begin
          if (InCSS[i] = WideChar(';')) then
            begin
              if ProcessRule(Temp) then
                Exit;
              Temp := '';
            end;
          Temp := Temp + InCSS[i];
        end;
      ProcessRule(Temp);
    end;
end;
//This function completely rewritten for v 1.6.
{procedure TAnnCategory.WriteToDomElement(El: TDomElement;
  OwnerDoc: TDomDocument);
var
ChildNode: TDomElement;
HiNode: TDomElement;
LabelNode: TDomElement;
TextNode: TDomText;

begin
  if El <> nil then
    begin
//Write the id
      El.SetAttribute('xml:id', ID);
//Write the Explanation to a label node
      LabelNode := TDomElement.Create(OwnerDoc, 'label');
      TextNode := TDomText.Create(OwnerDoc);
      TextNode.NodeValue := Explanation;
      LabelNode.AppendChild(TextNode);
      El.AppendChild(LabelNode);
//write the shape and colour to a hi node
      HiNode := TDomElement.Create(OwnerDoc, 'hi');
      HiNode.SetAttribute('rend', wsShape);
      TextNode := TDomText.Create(OwnerDoc);
      TextNode.NodeValue := CSS;
      HiNode.AppendChild(TextNode);
      El.AppendChild(HiNode);

    end;
end;      }

procedure TAnnCategory.WriteToDomElement(El: TDomElement;
  OwnerDoc: TDomDocument);
var
ChildNode: TDomElement;
CodeNode: TDomElement;
LabelNode: TDomElement;
DescNode: TDomElement;
TextNode: TDomText;

begin
  if El <> nil then
    begin
//Write the id
      El.SetAttribute('xml:id', ID);

//New for 1.8: write the "transcriptional" boolean in the form of a <desc> element.
      if (Transcriptional = True) then
        begin
          DescNode := TDomElement.Create(OwnerDoc, 'desc');
          TextNode := TDomText.Create(OwnerDoc);
          TextNode.NodeValue := 'transcriptional';
          DescNode.AppendChild(TextNode);
          El.AppendChild(DescNode);
        end;

//Write the Explanation to a label node
      LabelNode := TDomElement.Create(OwnerDoc, 'label');
      TextNode := TDomText.Create(OwnerDoc);
      TextNode.NodeValue := Explanation;
      LabelNode.AppendChild(TextNode);
      El.AppendChild(LabelNode);
//write the shape and colour to a code node
      CodeNode := TDomElement.Create(OwnerDoc, 'code');
      CodeNode.SetAttribute('rend', wsShape);
      CodeNode.SetAttribute('lang', 'text/css');
      TextNode := TDomText.Create(OwnerDoc);
      TextNode.NodeValue := CSS;
      CodeNode.AppendChild(TextNode);
      El.AppendChild(CodeNode);

    end;
end;

//This function rewritten for version 1.6
{procedure TAnnCategory.ReadFromDomElement(El: TDomElement);
var
wsTemp: WideString;
NewCSS: WideString;
LabelNode: TDomNode;
HiNode: TDomNode;

begin
  if El <> nil then
    begin
      wsTemp := WideTrim(El.GetAttributeNormalizedValue('xml:id'));
      if Length(wsTemp) > 0 then
        ID := wsTemp;
      if El.GetElementsByTagName('label').Length > 0 then
        begin
          LabelNode := El.GetElementsByTagName('label').Item(0);
          Explanation := WideTrim(LabelNode.textContent);
        end;
      if El.GetElementsByTagName('hi').Length > 0 then
        begin
          HiNode := El.GetElementsByTagName('hi').Item(0);
          wsTemp := WideTrim(HiNode.textContent);
          if Length(wsTemp) > 0 then
            CSS := wsTemp;
          wsTemp := WideTrim(TDomElement(HiNode).getAttributeNormalizedValue('rend'));
          if Length(wsTemp) > 0 then
            wsShape := wsTemp;
        end;
    end;
end;}

procedure TAnnCategory.ReadFromDomElement(El: TDomElement);
var
wsTemp: WideString;
NewCSS: WideString;
LabelNode: TDomNode;
DescNode: TDomNode;
CodeNode: TDomNode;
DescContent: WideString;

begin
  if El <> nil then
    begin
      wsTemp := WideTrim(El.GetAttributeNormalizedValue('xml:id'));
      if Length(wsTemp) > 0 then
        ID := wsTemp;
      if El.GetElementsByTagName('label').Length > 0 then
        begin
          LabelNode := El.GetElementsByTagName('label').Item(0);
          Explanation := WideTrim(LabelNode.textContent);
        end;
      if El.GetElementsByTagName('desc').Length > 0 then
        begin
          DescNode := El.GetElementsByTagName('desc').Item(0);
          DescContent := WideTrim(DescNode.TextContent);
          if Pos('transcriptional', DescContent) > 0 then
            Transcriptional := True
          else
            Transcriptional := False;
        end;
      if El.GetElementsByTagName('code').Length > 0 then
        begin
          CodeNode := El.GetElementsByTagName('code').Item(0);
          wsTemp := WideTrim(CodeNode.textContent);
          if Length(wsTemp) > 0 then
            CSS := wsTemp;
          wsTemp := WideTrim(TDomElement(CodeNode).getAttributeNormalizedValue('rend'));
          if Length(wsTemp) > 0 then
            wsShape := wsTemp;
        end;
    end;
end;

function TAnnCategory.GetwsShape: WideString;
begin
  Result := 'spiral'; //default
  case Shape of
    asSpiral: Result := 'spiral';
    asRectangle: Result := 'rectangle';
    asCross: Result := 'cross';
    asEllipse: Result := 'ellipse';
  end;
end;

procedure TAnnCategory.SetwsShape(const Value: WideString);
var
TrimVal: WideString;

begin
  TrimVal := WideTrim(Value);
  if TrimVal = WideString('rectangle') then
    SetShape(asRectangle)
  else
    if TrimVal = WideString('cross') then
      SetShape(asCross)
    else
      if TrimVal = WideString('ellipse') then
        SetShape(asEllipse)
      else
        SetShape(asSpiral);
end;


procedure TAnnCategory.SetID(const Value: WideString);
var
TrimVal: WideString;

begin
  TrimVal := WideTrim(Value);
  if fID <> TrimVal then
    begin
      fID := TrimVal;
      Modified := True;
    end;
end;

procedure TAnnCategory.SetTranscriptional(const Value: Boolean);
begin
  if fTranscriptional <> Value then
    begin
      fTranscriptional := Value;
      Modified := True;
    end;
end;
procedure TAnnCategory.SetExplanation(const Value: WideString);
var
TrimVal: WideString;

begin
  TrimVal := WideTrim(Value);
  if fExplanation <> TrimVal then
    begin
      fExplanation := TrimVal;
      Modified := True;
    end;
end;

{ TAnnCatList }

function TAnnCatList.AddCategory(NewCatID: WideString): integer;
begin
  Result := -1;
  try
    Add(TAnnCategory.Create);
    ID[Count-1] := NewCatID; //This ensures uniqueness
    Result := Count-1;
    Modified := True;
  except
//Returning -1 is sufficient
  end;
end;

function TAnnCatList.DeleteCategory(Index: integer): Boolean;
begin
  Result := False;
  try
    if IndexInRange(Index) then
      begin
        FreeAndNil(TAnnCategory(List[Index]));
        Delete(Index);
        Modified := True;
        Result := True;
      end
  except
//Returning false is sufficient
  end;
end;

procedure TAnnCatList.Empty;
var
i: integer;

begin
  if Count > 0 then
    begin
      for i := Count-1 downto 0 do
        begin
          FreeAndNil(TAnnCategory(List[i]));
          Delete(i);
        end;
      Modified := True;
    end;
end;

function TAnnCatList.GetID(Index: integer): WideString;
begin
  Result := '';
  if IndexInRange(Index) then
    Result := TAnnCategory(List[Index]).ID;
end;

function TAnnCatList.IDIsUnique(TheID: WideString; Index: integer): Boolean;
var
i: integer;

begin
  Result := True; //default
  if IndexInRange(Index) then
    for i := 0 to Count-1 do
      if (Index <> i) and (TheID = ID[i]) then
        Result := False;
end;

procedure TAnnCatList.EnforceUniqueIDs;
var
i, j: integer;
TheID: WideString;

begin
  if Count > 0 then
    for i := 0 to Count-1 do
      begin
        j := 1;
        TheID := ID[i];
        while not (IDIsUnique(TheID, i)) do
          begin
            inc(j);
            TheID := ID[i] + '_' + IntToStr(j);
          end;
        ID[i] := TheID;
      end;
end;

procedure TAnnCatList.SetID(Index: integer; const Value: WideString);
var
NewID: WideString;
i: integer;

begin
  NewID := WideTrim(Value);
//Enforce compliance with xml:id
  ufrmXMLUtilities.MakeXMLNCName(NewID);
  i := 1;
//Make sure it's unique. This will not invalidate it as xml:id.
  while not (IDIsUnique(NewID, Index)) do
    begin
      inc(i);
      NewID := WideTrim(Value) + '_' + IntToStr(i);
    end;
  TAnnCategory(List[Index]).ID := NewID;
end;

function TAnnCatList.IndexInRange(Index: integer): Boolean;
begin
  Result := False; //default
  if (Index > -1) and (Index < Count) then
    Result := True;
end;

function TAnnCatList.GetShape(Index: integer): integer;
begin
  Result := asSpiral; //default
  if IndexInRange(Index) then
    Result := TAnnCategory(List[Index]).Shape;
end;

procedure TAnnCatList.SetShape(Index: integer; const Value: integer);
begin
  if IndexInRange(Index) then
    TAnnCategory(List[Index]).Shape := Value;
end;

function TAnnCatList.GetColor(Index: integer): TColor;
begin
  Result := clRed; //default
  if IndexInRange(Index) then
    Result := TAnnCategory(List[Index]).Color;
end;

procedure TAnnCatList.SetColor(Index: integer; const Value: TColor);
begin
  if IndexInRange(Index) then
    TAnnCategory(List[Index]).Color := Value;
end;

function TAnnCatList.GetExplanation(Index: integer): WideString;
begin
  Result := ''; //default
  if IndexInRange(Index) then
    Result := TAnnCategory(List[Index]).Explanation;
end;

procedure TAnnCatList.SetExplanation(Index: integer; const Value: WideString);
begin
  if IndexInRange(Index) then
    TAnnCategory(List[Index]).Explanation := Value;
end;

procedure TAnnCatList.SetTranscriptional(Index: integer; const Value: Boolean);
begin
  if IndexInRange(Index) then
    TAnnCategory(List[Index]).Transcriptional := Value;
end;

function TAnnCatList.GetTranscriptional(Index: integer): Boolean;
begin
  Result := False; //default
  if IndexInRange(Index) then
    Result := TAnnCategory(List[Index]).Transcriptional;
end;

procedure TAnnCatList.WriteToEncodingDesc(EncDesc: TDomElement;
  OwnerDoc: TDomDocument);
var
tagsDecl, rendition: TDomElement;
i: integer;

begin
  if (EncDesc <> nil) and (Count > 0) then
    begin
      tagsDecl := TDomElement.Create(OwnerDoc, 'tagsDecl');
      tagsDecl.SetAttribute('xml:id', imtCategoryListID);
      for i := 0 to Count-1 do
        begin
          rendition := TDomElement.Create(OwnerDoc, 'rendition');
//Set the attributes of the rendition element
          TAnnCategory(List[i]).WriteToDomElement(rendition, OwnerDoc);
          tagsDecl.AppendChild(rendition);
        end;
      EncDesc.AppendChild(tagsDecl);
    end;
end;

procedure TAnnCatList.ReadFromEncodingDesc(EncDesc: TDomElement);
var
i, j: integer;
tagsDecl, rendition: TDomElement;
NewCat: integer;

begin
  Empty;
  if EncDesc.GetElementsByTagName('tagsDecl').Length > 0 then
    begin
      for i := 0 to EncDesc.GetElementsByTagName('tagsDecl').Length-1 do
        if TDomElement(EncDesc.GetElementsByTagName('tagsDecl').Item(i)).GetAttributeNormalizedValue('xml:id')
             = imtCategoryListID then
          begin
            tagsDecl := TDomElement(EncDesc.GetElementsByTagName('tagsDecl').Item(i));
            if tagsDecl.GetElementsByTagName('rendition').Length > 0 then
              for j := 0 to tagsDecl.GetElementsByTagName('rendition').Length-1 do
                begin
                  rendition := TDomElement(tagsDecl.GetElementsByTagName('rendition').Item(j));
                  NewCat := AddCategory('TempCategory');
                  TAnnCategory(List[NewCat]).ReadFromDomElement(rendition);
                end;
          end;
    end;
  EnforceUniqueIDs;
end;

function TAnnCatList.FindCategoryFromColorAndShape(TheColor: TColor;
  TheShape: integer; var CatID: WideString): integer;
var
i: integer;

begin
  Result := -1; //default
  CatID := ''; //default
  if Count > 0 then
    for i := 0 to Count-1 do
      if (Color[i] = TheColor) and
          (Shape[i] = TheShape) then
        begin
          Result := i;
          CatID := ID[i];
          break;
        end;
end;

function TAnnCatList.GetShapeFromCatID(CatID: WideString): integer;
begin
  Result := Shape[FindCategoryNumFromID(CatID)];
end;

function TAnnCatList.GetColorFromCatID(CatID: WideString): TColor;
begin
  Result := Color[FindCategoryNumFromID(CatID)];
end;

function TAnnCatList.GetExplanationFromCatID(CatID: WideString): WideString;
begin
  Result := Explanation[FindCategoryNumFromID(CatID)];
end;

function TAnnCatList.GetTranscriptionalFromCatID(CatID: WideString): Boolean;
begin
  Result := Transcriptional[FindCategoryNumFromID(CatID)];
end;

function TAnnCatList.FindCategoryNumFromID(CatID: WideString): integer;
var
i: integer;

begin
  Result := -1; //default
  if Count > 0 then
    for i := 0 to Count-1 do
      if ID[i] = CatID then
        begin
          Result := i;
          Exit;
        end;
end;

function TAnnCatList.GetModified: Boolean;
var
i: integer;
begin
  Result := fModified;
  if Count > 0 then
    for i := 0 to Count-1 do
      Result := Result or TAnnCategory(List[i]).Modified;
end;

procedure TAnnCatList.SetModified(const Value: Boolean);
var
i: integer;

begin
  fModified := Value;
  if (Value = False) then
    if Count > 0 then
      for i := 0 to Count-1 do
        TAnnCategory(List[i]).Modified := False;
end;

function TAnnCatList.SwapCategories(CatNum1, CatNum2: integer): Boolean;
begin
  Result := False;
  if IndexInRange(CatNum1) then
    if IndexInRange(CatNum2) then
      try
        Exchange(CatNum1, CatNum2);
        Result := True;
        Modified := True;
      except
        Result := False;
      end;
end;





end.