builder.pas

支持自定义语法高亮显示的编辑器控件

end;

{--------------------------------------------}

function TfrmBuilder.IsTokenUsed: boolean;
var
  i     : integer;
  j     : integer;
  k     : integer;
  index : integer;
  expr  : TSchemeExpressions;
begin
  result := false;
  index := GetTokenIndex;
  if index < 0 then
    Exit;
  for i := 0 to Scheme.States.Count - 1 do
  begin
    for j := 0 to Scheme.States[i].Reswords.Count - 1 do
      if Scheme.Tokens.IndexOf(Scheme.States[i].Reswords[j].Token) = index then
      begin
        result := true;
        Exit;
      end;
    for j := 0 to Scheme.States[i].Blocks.Count - 1 do
    begin
      expr := TSchemeExpressions(Scheme.States[i].Blocks.Objects[j]);
      for k := 0 to expr.Count - 1 do
        if Scheme.Tokens.IndexOf(expr[k].Token) = index then
        begin
          result := true;
          Exit;
        end;
    end;
  end;
end;

{--------------------------------------------}

function TfrmBuilder.GetTokenIndex: integer;
var
  kind : TNodeKind;
begin
  result := -1;
  kind := GetNodeKind;
  if kind = nkToken then
    result := tvScheme.Selected.Index;
end;

{--------------------------------------------}

procedure TfrmBuilder.edLanguageExit(Sender: TObject);
begin
  edLanguage.Text := Scheme.Language;
end;

{--------------------------------------------}

procedure TfrmBuilder.edCopyrightExit(Sender: TObject);
begin
  edCopyright.Text := Scheme.Copyright;
end;

{--------------------------------------------}

procedure TfrmBuilder.edWWWExit(Sender: TObject);
begin
  edWWW.Text := Scheme.WWW;
end;

{--------------------------------------------}

procedure TfrmBuilder.edMailExit(Sender: TObject);
begin
  edMail.Text := scheme.EMail;
end;

{--------------------------------------------}

procedure TfrmBuilder.edDelimitersExit(Sender: TObject);
begin
  edDelimiters.Text := Scheme.Delimiters;
end;

{--------------------------------------------}

procedure TfrmBuilder.chbCaseSensitiveClick(Sender: TObject);
var
  i  : integer;
begin
  Scheme.CaseSensitive := chbCaseSensitive.Checked;
  for i := 0 to Scheme.States.Count - 1 do
    Scheme.States[i].CaseSensitive := Scheme.CaseSensitive;
end;

{--------------------------------------------}

procedure TfrmBuilder.edStateNameKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_RETURN) and (tvScheme.Selected <> nil) then
    begin
      tvScheme.Selected.Text := edStateName.Text;
      UpdateStates;
    end;
end;

{--------------------------------------------}

procedure TfrmBuilder.edTokenNameKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_RETURN) and (tvScheme.Selected <> nil) then
  begin
    tvScheme.Selected.Text := edTokenName.Text;
    UpdateTokens;
  end;
end;

{--------------------------------------------}

procedure TfrmBuilder.edBlockNameKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_RETURN) and (tvScheme.Selected <> nil) then
  begin
    tvScheme.Selected.Text := edBlockName.Text;
    UpdateBlocks;
  end;
end;

{--------------------------------------------}

procedure TfrmBuilder.cbStateChange(Sender: TObject);
var
  expr : TSchemeExpression;
begin
  if FUpdating then
    Exit;
  expr := GetExpression;
  if expr = nil then
    exit;
  if cbState.ItemIndex < 0 then
    expr.State := ''
  else
    expr.State := Scheme.States[cbState.ItemIndex].Name;
end;

{--------------------------------------------}

procedure TfrmBuilder.cbTokenChange(Sender: TObject);
var
  expr : TSchemeExpression;
begin
  if FUpdating then
    Exit;
  expr := GetExpression;
  if expr = nil then
    exit;
  if cbToken.ItemIndex < 0 then
    expr.Token := ''
  else
    expr.Token := Scheme.Tokens[cbToken.ItemIndex];
end;

{--------------------------------------------}

procedure TfrmBuilder.cbReswordStateChange(Sender: TObject);
var
  resword : TSchemeExpression;
begin
  if FUpdating then
    Exit;
  resword := GetResword;
  if resword = nil then
    Exit;
  if cbReswordState.ItemIndex < 0 then
    resword.State := ''
  else
    resword.State := Scheme.States[cbReswordState.ItemIndex].Name;
end;

{--------------------------------------------}

procedure TfrmBuilder.cbReswordTokenChange(Sender: TObject);
var
  resword : TSchemeExpression;
begin
  if FUpdating then
    Exit;
  resword := GetResword;
  if resword = nil then
    Exit;
  if cbReswordToken.ItemIndex < 0 then
    resword.Token := ''
  else
    resword.Token := Scheme.Tokens[cbReswordToken.ItemIndex];
end;

{--------------------------------------------}

procedure TfrmBuilder.lbExpressionsClick(Sender: TObject);
begin
  UpdateExprProp;
end;

{--------------------------------------------}

procedure TfrmBuilder.cbExpressionsKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  expr : TSchemeExpression;
begin
  if key = VK_RETURN then
  begin
    expr := GetExpression;
    if expr = nil then
      AddExpression(cbExpressions.Text)
    else
    begin
      expr.Expression := cbExpressions.Text;
      lbExpressions.Items[lbExpressions.ItemIndex] :=
       cbExpressions.Text;
    end;
  end;
end;

{--------------------------------------------}

procedure TfrmBuilder.edStateNameExit(Sender: TObject);
var
  state : TSchemeState;
begin
  state := GetState;
  if state <> nil then
    edStateName.Text := state.Name;
end;

{--------------------------------------------}

procedure TfrmBuilder.edTokenNameExit(Sender: TObject);
var
  index : integer;
begin
  index := GetTokenIndex;
  if (index >= 0) and (index < Scheme.Tokens.Count) then
    edTokenName.Text := Scheme.Tokens[index];
end;

{--------------------------------------------}

procedure TfrmBuilder.edBlockNameExit(Sender: TObject);
var
  index : integer;
  state : TSchemeState;
begin
  state := GetState;
  index := GetBlockNumber;
  if (state <> nil) and (index >= 0) and (index < state.Blocks.Count) then
    edBlockName.Text := state.Blocks[index];
end;

{--------------------------------------------}

procedure TfrmBuilder.cbExpressionsExit(Sender: TObject);
var
  expr : TSchemeExpression;
begin
  expr := GetExpression;
  if (expr <> nil) then
    cbExpressions.Text := expr.Expression;
end;

{--------------------------------------------}

procedure TfrmBuilder.lbReswordsClick(Sender: TObject);
begin
  UpdateReswordProp;
end;

{--------------------------------------------}

procedure TfrmBuilder.UpdateReswordProp;
var
  expr : TSchemeExpression;
begin
  expr := GetResword;
  if expr <> nil then
  begin
    gbReswordProperties.Enabled := true;
    cbReswordState.ItemIndex :=
      cbReswordState.Items.IndexOf(expr.State);
    cbReswordToken.ItemIndex :=
      cbReswordToken.Items.IndexOf(expr.Token);
    edReswordName.Text := expr.Expression;
  end
  else
  begin
    gbReswordProperties.Enabled := false;
    cbReswordState.ItemIndex := - 1;
    cbReswordToken.ItemIndex := - 1;
    edReswordName.Text := '';
  end;
end;

{--------------------------------------------}

procedure TfrmBuilder.AddResword(const Value: string);
var
  state    : TSchemeState;
  i        : integer;
  exprName : string;
begin
  state := GetState;
  if state = nil then
    Exit;
  i := GetNewNumber(lbReswords.Items, sNewResword);
  if Value <> '' then
    exprName := Value
  else
    exprName := sNewResword + IntToStr(i);
  lbReswords.ItemIndex := lbReswords.Items.Add(exprName);
  state.Reswords.Insert(exprName, lbReswords.ItemIndex);
  UpdateReswordProp;
end;

{--------------------------------------------}

procedure TfrmBuilder.DeleteResword;
var
  expr  : TSchemeExpression;
  index : integer;
begin
  expr := GetResword;
  if expr <> nil then
  begin
    expr.Free;
    index := lbReswords.ItemIndex;
    lbReswords.Items.Delete(index);
    index := Min(index, lbReswords.Items.Count - 1);
    lbReswords.ItemIndex := index;
    UpdateReswordProp;
  end;
end;

{--------------------------------------------}

procedure TfrmBuilder.Addresword1Click(Sender: TObject);
begin
  AddResword('');
end;

{--------------------------------------------}

procedure TfrmBuilder.Deleteresword1Click(Sender: TObject);
begin
  DeleteResword;
end;

{--------------------------------------------}

procedure TfrmBuilder.edReswordNameKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  index :integer;
  state : TSchemeState;
  expr  : TSchemeExpression;
begin
  if key = VK_RETURN then
    begin
      expr := GetResword;
      if expr = nil then
        AddResword(edReswordName.Text)
      else
      begin
        state := GetState;
        lbReswords.Sorted := false;
        expr.Expression := edReswordName.Text;
        index := lbReswords.ItemIndex;
        lbReswords.Items[lbReswords.ItemIndex] := edReswordName.Text;
        lbReswords.Sorted := true;
        lbReswords.ItemIndex := lbReswords.Items.IndexOf(edReswordName.Text);
        state.Reswords.Items[index].Index := lbReswords.ItemIndex;
      end;
    end;
end;

{--------------------------------------------}

procedure TfrmBuilder.edReswordNameExit(Sender: TObject);
var
  expr : TSchemeExpression;
begin
  expr := GetResword;
  if (expr <> nil) then
    edReswordName.Text := expr.Expression;
end;

{--------------------------------------------}

procedure TfrmBuilder.pmReswordsPopup(Sender: TObject);
begin
  Deleteresword1.Enabled := lbReswords.ItemIndex >= 0;
end;

{--------------------------------------------}

procedure TfrmBuilder.chbStateCaseSensitiveClick(Sender: TObject);
var
  i     : integer;
  state : TSchemeState;
begin
  state := GetState;
  if state <> nil then
    state.CaseSensitive := chbStateCaseSensitive.Checked;

  for i := 0 to Scheme.States.Count - 1 do
    if Scheme.States[i].CaseSensitive then
    begin
      Scheme.CaseSensitive := true;
      Break;
    end;

end;

{--------------------------------------------}

function TfrmBuilder.GetCaseSensitive : boolean;
var
  i : integer;
begin
  if Scheme.States.Count = 0 then
    result := Scheme.CaseSensitive
  else
    result := true;
  for i := 0 to Scheme.States.Count - 1 do
    if Scheme.States[i].CaseSensitive then
    begin
      result := true;
      Exit;
    end;
end;

{--------------------------------------------}

procedure TfrmBuilder.UpdateGeneralPanel;
begin
  edLanguage.Text := Scheme.Language;
  edCopyright.Text := Scheme.Copyright;
  edWWW.Text := Scheme.WWW;
  edMail.Text := Scheme.EMail;
  edDelimiters.Text := Scheme.Delimiters;
  chbCaseSensitive.Checked := Scheme.CaseSensitive;
end;

{--------------------------------------------}

procedure TfrmBuilder.tvSchemeExpanded(Sender: TObject; Node: TTreeNode);
begin
  UpdateNodeIndex(Node, true);
end;

{--------------------------------------------}

procedure TfrmBuilder.tvSchemeCollapsed(Sender: TObject; Node: TTreeNode);
begin
  UpdateNodeIndex(Node, false);
end;

{--------------------------------------------}

procedure TfrmBuilder.tvSchemeDeletion(Sender: TObject; Node: TTreeNode);
begin
  UpdateNodeIndex(Node.Parent, false, true);
end;

{--------------------------------------------}

procedure TfrmBuilder.UpdateNodeIndex(Node: TTreeNode; IsExpanded : boolean; IsDeleted : boolean);
var
  index : integer;
begin
  if Node = nil then
    Exit;
  if IsDeleted then
  begin
    if (Node.Count > 1) then
      index := cOpenFolderIndex
    else
      index := cCloseFolderIndex;
  end
  else
    if (Node.Count > 0) and IsExpanded then
      index := cOpenFolderIndex
    else
      index := cCloseFolderIndex;
  Node.ImageIndex := index;
  Node.SelectedIndex := index;
end;

{--------------------------------------------}

end.