˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙//*************************************************************
**********
//*
//*       Název makra:   Nastavení barev
//*             Autor:   Software602 a.s.
//*   Datum vytvoření:   17.12.1996
//*
//*     Název souboru:   
//*    Název programu:   
//*              Tisk:    
//*
//*             Popis:   Nastavení barev ve zdrojovém textu 
makra
//*                      (klíčové slova, komentáře...)
//*
//*************************************************************
*****mt***
program Nastav_barvy;

const
  COUNT          = 32;
  MAXLEN         = 15;

  FIND_COMMENT   = 101;
  FIND_STRING    = 102;
  FIND_NUMBER    = 103;
  FIND_MRIZKA    = 104;


var
  keyWord :array[1..COUNT] of string[MAXLEN];
  startPos :integer;                          // původní 
umístění kurzoru
  start_pos, end_pos, actual_pos :integer;
  endDoc :integer;                            // konec 
dokumentu
  changeWords :integer;                       // počet 
nalezených slov
  s :string[50];

  CAPTION :string[20];                        // název makra
  RESULT_COUNT :string[100];



procedure init;
begin
  keyWord[1]  := 'AND';
  keyWord[2]  := 'ARRAY';
  keyWord[3]  := 'BEGIN';
  keyWord[4]  := 'CASE';
  keyWord[5]  := 'CONST';
  keyWord[6]  := 'CSISTRING';
  keyWord[7]  := 'CSSTRING';
  keyWord[8]  := 'DIV';
  keyWord[9]  := 'DO';
  keyWord[10] := 'DOWNTO';
  keyWord[11] := 'ELSE';
  keyWord[12] := 'END';
  keyWord[13] := 'FILE';
  keyWord[14] := 'FOR';
  keyWord[15] := 'FUNCTION';
  keyWord[16] := 'HALT';
  keyWord[17] := 'IF';
  keyWord[18] := 'MOD';
  keyWord[19] := 'NOT';
  keyWord[20] := 'OF';
  keyWord[21] := 'OR';
  keyWord[22] := 'PROCEDURE';
  keyWord[23] := 'PROGRAM';
  keyWord[24] := 'RECORD';
  keyWord[25] := 'REPEAT';
  keyWord[26] := 'STRING';
  keyWord[27] := 'THEN';
  keyWord[28] := 'TO';
  keyWord[29] := 'TYPE';
  keyWord[30] := 'UNTIL';
  keyWord[31] := 'VAR';
  keyWord[32] := 'WHILE';

  { stringy : }
  CAPTION := 'SetColor';
  RESULT_COUNT := 'Počet nalezených klíčových slov: ';

  { caret : }
  startPos := GetCaretPos;
  CaretEnd(false);
  endDoc := GetCaretPos;
  CaretHome(false);

  { ostatní proměnné : }
  changeWords := 0;
end;


procedure setColor_COMMENT;
begin
  SetRGBColor(128, 128, 128);
  SetFormatFont(kCHPitalic, kOn);
end;


procedure setColor_STRING;
begin SetRGBColor(0, 0, 255); end;


procedure setColor_MRIZKA;
begin SetRGBColor(128, 0, 0); end;


procedure setColor_NUMBER;
begin SetRGBColor(0, 0, 255); end;


procedure setColor_KEYWORD;
begin
  SetFormatFont(kCHPbold, kOn);     // bold
{  SetRGBColor(255, 255, 255);}       // bílá
{  SetRGBColor(255, 255, 0);}         // žlutá
{  SetRGBColor(0, 0, 128);}           // tmavě modrá
end;


function FindEndOf(readStr:string[2]; p, typ:integer):integer;
{ readStr: načtený řetězec
  p:       počáteční pozice
  typ:     typ vyhledávaného řetězce }
var
  actual_pos, sz :integer;
  konec :boolean;
  s :string[2];
  znak :char;
  result, countChars :integer;
begin
  sz := StrLength(readStr);
  countChars := 0;
  result := -1;
  actual_pos := p + sz;
  konec := false;
  UnSelectBlock;

  { nastavení caretu na začátek řetězce : }
  CharRight(p-GetCaretPos, false);

  { selektování prvních znaků : }
  if (readStr = '//') and (typ = FIND_COMMENT) then begin
    { aby si caret uvědomil, kde je jeho místo : }
    CharRight; CharLeft; end;
  CharRight(sz, true);

  { jestliže je typ komentáře '//', selektuj do konce řádky : 
}
  if (readStr = '//') and (typ = FIND_COMMENT) then begin
    RightOfLine(true);
    result := GetCaretPos-1;
    konec := true;
  end;

  while not(konec) and (actual_pos < endDoc) do begin
    s := GetText(actual_pos, actual_pos+1);

    case (typ) of
      FIND_COMMENT: begin
        znak := s;
        if (znak = '*') then begin
          s := s + GetText(actual_pos+1, actual_pos+2);
          inc(actual_pos);
        end;
        konec := (ord(znak) = 125) or (s = '*)') or (s = 
'*/');
        result := actual_pos;
        inc(countChars, StrLength(s));
      end;

      FIND_STRING: begin
        znak := s;
        konec := ((ord(znak) = 39) or (ord(znak) = 34));
        result := actual_pos;
        inc(countChars, 1);
      end;

      FIND_NUMBER: begin
        znak := s;
        konec :=
          not(((ord(znak) >= 48) and (ord(znak) <= 57)) or 
(znak = '.'));
        result := actual_pos-1;
        inc(countChars, 1);
      end;

      FIND_MRIZKA: begin
        znak := s;
        konec := (znak <> '#');
        result := actual_pos-1;
        inc(countChars, 1);
      end;
    end; { case }

    inc(actual_pos);
  end; { while }

  { selektuj vybraný text, ale pouze v případě, že hledaný 
text není
    komentář typu '//', ten už je selektovaný : }
  if not((readStr = '//') and (typ = FIND_COMMENT)) then
    CharRight(countChars, true);

  case (typ) of
    FIND_COMMENT: setColor_COMMENT;
    FIND_STRING:  setColor_STRING;
    FIND_MRIZKA:  setColor_MRIZKA;
    FIND_NUMBER:  begin CharLeft(1, true); setColor_NUMBER; 
end;
  end;

  UnselectBlock;
  FindEndOf := result;
end;


function CharIsOK(znak:char):boolean;
begin
  CharIsOK :=
    (((ord(znak) >= 97) and (ord(znak) <= 122)) or
    ((ord(znak) >= 65) and (ord(znak) <= 90)) or
    (znak = '_'));
end;


function GetBeginOfWord(p:integer):integer;
var
  result :integer;
  konec :boolean;
  znak :char;
  znak2 :char;
  readStr :string[2];
begin
  result := -1;
  konec := false;
  actual_pos := p;

  while not(konec) and (actual_pos < endDoc) do begin
    znak := GetText(actual_pos, actual_pos+1);
    if (znak = '(') or (znak = '/')
      then znak2 := GetText(actual_pos+1, actual_pos+2)
      else begin if (actual_pos >= 1)
        then znak2 := GetText(actual_pos-1, actual_pos)
        else znak2 := (chr(255))
      end;
    readStr := Char2Str(znak) + Char2Str(znak2);

    { komentář : }
    if (znak = '{')
      then actual_pos := FindEndOf(znak, actual_pos, 
FIND_COMMENT)

    { komentář : }
    else if ((znak = '(') and (znak2 = '*')) or
    ((znak = '/') and (znak2 = '*')) or
    ((znak = '/') and (znak2 = '/'))
      then actual_pos := FindEndOf(readStr, actual_pos, 
FIND_COMMENT)

    { řetězec : }
    else if (ord(znak) = 39) or (ord(znak) = 34)
      then actual_pos := FindEndOf(znak, actual_pos, 
FIND_STRING)

    { číslo : }
    else if (ord(znak) >= 48) and (ord(znak) <= 57)
    and not(CharIsOK(znak2))
      then actual_pos := FindEndOf(znak, actual_pos, 
FIND_NUMBER)

    { mřížka : }
    else if (znak = '#')
      then actual_pos := FindEndOf(znak, actual_pos, 
FIND_MRIZKA)

    { nalezeno : }
    else if (CharIsOK(znak)) then begin
      konec := true;
      result := actual_pos;
    end;

    inc(actual_pos);
  end; { while }

  GetBeginOfWord := result;
end;


function GetEndOfWord(p:integer):integer;
var
  result :integer;
  konec :boolean;
  znak :char;
begin
  result := p;
  konec := false;
  actual_pos := p;
  while not(konec) do begin
    znak := GetText(actual_pos, actual_pos+1);
    if((ord(znak) < ord('A')) or (ord(znak) > ord('Z'))) and
      ((ord(znak) < ord('a')) or (ord(znak) > ord('z'))) and
      ((ord(znak) < ord('0')) or (ord(znak) > ord('9'))) and
      (znak <> '_') then begin
      konec := true;
      result := actual_pos;
    end;
    inc(actual_pos);
  end; { while }
  GetEndOfWord := result;
end;


function IsOK(s:string[MAXLEN]):boolean;
var
  i :integer;
  nalezeno :boolean;
begin
  i := 1;
  nalezeno := false;
  s := UpCase(s);
  while (i <= COUNT) and not(nalezeno) do begin
    nalezeno := (s = UpCase(keyWord[i]));
    inc(i);
  end;
  IsOK := nalezeno;
end;


procedure Run;
var
  beginPos, endPos :integer;
  s :string[MAXLEN];
  i :integer;
  konec :boolean;
begin
  endPos := GetCaretPos;
  beginPos := endPos + 1;
  konec := false;
  while not(konec) do begin
    beginPos := GetBeginOfWord(endPos);
    if (beginPos >= 0) then begin
      endPos := GetEndOfWord(beginPos);
      if ((endPos - (beginPos+1)) <= MAXLEN) then begin
        s := GetText(beginPos, endPos);
        if (IsOK(s)) then begin
          inc(changeWords);
          CharRight(beginPos-GetCaretPos, false);
          { přeskočení prázdných odstavců : }
          if (GetCaretPos <> endPos) then begin
            CharRight(1,false);
            CharLeft(1,false);
          end
          else begin
            CharLeft(1,false);
            CharRight(1,false);
          end;
          CharRight(endPos-beginPos, true);
          setColor_KEYWORD;
        end;
      end;
    end
    else konec := true;
  end;
end;



begin
  init;
  Run;
  CaretHome;
  CharRight(startPos);
  s := RESULT_COUNT + Int2str(ChangeWords);
  info_box(CAPTION, s);
end.