Object Pascal e Análise do Comportamento

  // Esta linha está comentada, pois inicia com duas barras.

 // Esta linha está comentada
 Este trecho não está comentado, // mas este está.

  // Esta linha está comentada
 {
    Este trecho também está comentado,
    pois está entre chaves simples.
 }

 // Esta linha está comentada
 Este trecho não, { este sim } este não.

program ProjetoPiloto // declara o identificador ProjetoPiloto
;  // finaliza o bloco de declaração do identificador do programa
begin  // inicia o bloco de comandos central
  WriteLn('Olá Mundo!'); // escreve o texto 'Olá Mundo!' e uma linha no console 
end. // finaliza o bloco de comandos central e o módulo

PROGRAM projetopiloto;
BEGIN                   
  writeln('Olá Mundo!');              
END.                    

program projetopiloto;begin WriteLn('Olá Mundo!');end.

unit Unit1; // inicia a unidade Unit1
 
interface   // inicia o bloco público da unidade                
 
uses   // a palavra "uses" inicia um "bloco de uso" e permite usar outras unidade
 Unit2, Unit3;  // as unidades 2 e 3 estão sendo usadas
 
{  As interfaces das unidades 2 e 3 são visíveis
    em toda a unidade 1 (esta unidade).}
 
implementation  // final do bloco público e início do bloco privado da unidade
 
uses Unit4;           
 
{  Mas a interface da unidade 4 é visível apenas
    na implementação da unidade 1 (esta unidade). }
 
end.            // final da unidade

program ProjetoPiloto;
uses DateUtils, SysUtils;
begin
  WriteLn(DateTimeToStr(Today));
end.

var                  // inicia um bloco de declaração de variáveis
  b : boolean = true; // declara ‘b’ como um tipo ‘boleano’ inicializando-o com true
  i : integer = -1;   // declara ‘i’ como um ‘número inteiro inicializando-o com -1
  s : string  = 'Texto'; // declara ‘s’ como um texto inicializando-o com "Texto" 
begin
  WriteLn(b);            // converte o valor para texto e o mostra no console
  WriteLn(i);            // converte o valor para texto e o mostra no console
  WriteLn(s);            // mostra o texto no console
end. 

const       // inicia um bloco de declaração de constantes
  tab = #9; // declara uma constante com um caractere não imprimível (tab)
var          
  b : boolean;  // declara ‘b’ como boleano  
  i : integer;  // declara ‘i’ como inteiro
  s : string;   // declara ‘s’ como texto 
begin
  b := false;   // atribui false à variável ‘b’
  i := 10;      // atribui 10 à variável ‘i’
  s := 'texto'; // atribui "texto" à variável ‘s’
 
  // imprime as variáveis no console usando o tab como separador
  WriteLn(b, tab, i, tab, s); 
 
  // tab := #32; isso não é possível, pois ‘tab’ é uma constante
end. 

var
  b : boolean = false;
  i : integer = 10;
  s : string  = 'texto';
begin
  // Operações Boleanas
  b := not B;       // inverte o valor de B (para true)
  b := not B;       // inverte o valor de B (para false)
  b := 10 > 9;      // dez é maior do que nove? true
  b := 10 < 9;      // dez é menor do que nove? false
  b := 10 = 9;      // dez é igual à nove? false
  b := 10 <> 9;     // dez é diferente de 9? true
 
  //  cuidado! a comparação entre texto diferencia maiúsculas e minúsculas
  b := s = 'texto'; // os textos são iguais? true
  b := s <> 'Texto';// os textos são diferentes! true
 
  // Operações Aritméticas
  i := -i;          // inverte o sinal de i para negativo
  i := -i;          // inverte o sinal de i para positivo
  i := 10 + 10;     // soma entre dois inteiros
  i := 10 - 1;      // diferença entre dois inteiros
  i := 10 * 10;     // multiplicação entre dois inteiros
  i := 10 div 10;   // divisão entre dois inteiros
  i := 10 mod 3;    // resto da divisão entre dois inteiros
 
  // Operações com texto
  s := 'texto'+'texto'+'texto';     // concatenar texto  
end.

var
  i : integer;
begin 
  {
    Observação:
    True e False são os valores boleanos
    pré-definidos pela linguagem
  }
 
  // neste caso, o uso de um valor pré-definido torna a condição sempre verdadeira
  if True then
    begin 
      i := 1; // então este comando sempre será executado
    end
  else
    begin
      i := 0; // e este nunca será executado
    end;
 
  // neste caso a condição é sempre falsa
  if False then
    begin 
      i := 1; // então este comando nunca será executado
    end
  else
    begin
      i := 0; // e este sempre será executado
    end;
 
  // neste momento, o que será escrito no console?
  if i = 0 then WriteLn(i) else WriteLn('A');
 
  // e agora, o que será escrito no console?
  if i = 0 then WriteLn('A') else WriteLn(i);
end.

var
  i : integer = 0;  // inicializa i com o valor 0
  s : string = 'a'; // inicializa s com o texto 'a'
begin
  // casos sobre valores
  case i of
    0 :           // caso i seja igual a 0
      i := 1; // este comando será executado, pois i é igual a zero
    1 :           // caso i seja igual a 1
      i := 2;     
    2 :           // caso i seja igual a 2
      i := 3;          
  else
  // este comando será executado se nenhum dos casos especificados ocorrer
    i := -1;      
  end;
 
  // casos sobre texto
  case s of
    'a'    : i := 0; // este comando será executado, pois s é igual a 'a'
    'b'    : i := 1; // caso s seja 'b'
    'casa' : i := 2; // caso s seja 'casa'
  else
    i := -1;          
  end;
end.

var
  i : integer;
begin
  i := 100; 
  repeat            
    i := i + 1;    // executa o bloco de comandos primeiro
  until i < 100;   // testa a condição de saída ao final 
  // portanto i será igual a 101
end.

var
  i : integer;
begin
  // repetir enquanto uma condição for verdadeira:
  i := 100;
  while i < 100 do // a condição de saída é executada primeiro
  begin            // portanto este bloco não será executado
    i := i + 1;  
  end;
 
  i := 100;
  while i = 100 do // condição verdadeira, portanto
    i := i + 1;    // este bloco será executado uma vez
 
  // condições de saída customizadas podem ser criadas
  // com o procedimento de saída de laço "Break" e condições
 
  // o laço a seguir executaria infinitamente 
  // pois True é uma variável do sistema e não muda
  // a única maneira de sair desse laço é por meio
  // do procedimento de saída de laço "Break"
  i := 0;
  while True do 
  begin
    WriteLn(i);       // escreva o valor de i no console
    i := i + 1;       // incremente i
    if i > 4 then     // se i maior do que 4 (condição de saída) então 
      Break;          // saia do laço infinito
  end;
  // WriteLn produzirá "0, 1, 2, 3, 4" no console
 
  // também é possível pular comandos dentro do bloco de repetições
  // por meio do procedimento "Continue"
  i := 0;
  while True do     // execute infinitamente
  begin             // início do bloco de repetições
    if i < 4 then   // se menor do que 4
    begin
      WriteLn(i);   // escreva o valor de i no console                    
      i := i + 1;   // incremente 1
      Continue;     // e continue do início
    end;
                  // se 5 ou maior
    i := i + 1;     // incremente 1
    WriteLn(i);     // escreva o valor de i no console
    Break;          // saia do laço infinito
  end;              // fim
  // WriteLn produzirá "0, 1, 2, 3, 5" no console
  // o número quatro foi pulado 
end.

var
  i : integer;
begin
  for i := 0 to 9 do // do menor para o maior
    begin
      WriteLn(i);  // 0, 1 .. 9
    end;
   
  for i := 9 downto 0 do   // do maior para o menor
    begin
      WriteLn(i); // 9, 8 .. 0
    end;
   
  { Esses laços também permitem o uso dos procedimentos  Break e Continue }    
end.

const
  space = #32;
var
  // declara e inicializa um vetor estático
  names : array [0..4] of string = ('joao', 'maria', 'rafael', 'thais', 'laura'); 
 
  // declara uma variável de tipo igual ao do vetor
  name : string;
 
  // apenas inteiros podem servir como índice de vetores
  i : integer;
begin
// percorra os items de um vetor sem se preocupar com seus índices
  for name in names do
    WriteLn(name);
 
  // percorra os items de qualquer vetor por meio de seus índices
  for i:= Low(names) to High(names) do
    begin
      WriteLn(i, space, names[i]);
    end;     end.

var
  numbers : array of integer; // declara um vetor dinâmico
  number : integer;
begin
  SetLength(numbers, 2);  // inicializa um vetor com 2 itens  
 
  // retorna o tamanho de um vetor, neste caso igual a 2
  // Length(numbers);     
 
  // retorna o maior índice de um vetor, neste caso igual a 1
  // High(numbers);       
 
  // retorna o menor índice de um vetor, neste caso igual a 0
  // Low(numbers);        
 
  // atribui um valor ao primeiro item do vetor
  numbers[0] := 100;      
 
  // atribui um valor ao segundo item do vetor
  numbers[1] := 200;      
 
  // expande o vetor, agora ele possui 3 itens
  SetLength(numbers, Length(numbers)+1);  
 
  // atribui um valor ao terceiro item, 
  numbers[2] := 300;
 
  // reduz um vetor, agora ele possui 2 itens
  SetLength(numbers, Length(numbers)-1);  
 
  // ao reduzir um vetor,
  // a liberação ocorre na ordem do maior para o menor índice
  // de tal forma que os itens iniciais
  // não são alterados ao reduzir o tamanho
  for number in numbers do WriteLn(number);  
end.

uses Classes; // torna o tipo ‘TStringList’ visível neste módulo
 
var
  Names : TStringList; // declara Names como do tipo TStringList
  name : string;      
begin
  // Note que o caractere "ponto" (.) é utilizado
  // para acessar o conteúdo de classes e objetos
 
  // inicializa um objeto do tipo lista de texto (TStringList)
  Names := TStringList.Create;         
 
  // atribui um texto delimitado à lista
  Names.DelimitedText := 'thais maria clara bárbara joana'; 
 
  // adiciona um item ao final da lista
  Names.Append('marcela');                
 
  // percorre a lista escrevendo cada nome
  for name in Names do WriteLn(name);  
 
  // libera a lista da memória
  Names.Free; 
 
  // Sempre libere as listas da memória ao final!
end.

var
 i : integer;
begin
 
  i := 1;
  WriteLn('-------------------------------------');
  WriteLn('-    bloco de comandos    -');
  WriteLn('-------------------------------------'); WriteLn(i);
 
  i := 2;
  WriteLn('-------------------------------------');
  WriteLn('-    bloco de comandos    -');
  WriteLn('-------------------------------------'); WriteLn(i);
 
  i := 3;
  WriteLn('-------------------------------------');
  WriteLn('-    bloco de comandos    -');
  WriteLn('-------------------------------------'); WriteLn(i);
 
  i := 4;
  WriteLn('-------------------------------------');
  WriteLn('-    bloco de comandos    -');
  WriteLn('-------------------------------------'); WriteLn(i);
end.

  // declara o procedimento WriteBloc com o argumento ABlocNumber
 procedure WriteBloc(ABlocNumber : integer);
  begin
    WriteLn('-------------------------------------');
    WriteLn('-    bloco de comandos    -');
    WriteLn('-------------------------------------');
    WriteLn(ABlocNumber);
 end;  
 
  var
    i : integer;
      
  begin
    i := 1;
    WriteBloc(i); // chama o procedimento
 
    i := 2;
    WriteBloc(i);
 
    i := 3;
    WriteBloc(i);
 
    i := 4;
    WriteBloc(i);
 end.
 
Um laço evitaria ainda mais repetições:
 
  begin
    for i := 1 to 4 do WriteBloc(i);
 end.

 unit Unit1;
  {   apenas a assinatura de procedimentos pode ser
    declarada na interface de uma unidade }
 interface 
 
  { procedimentos possuem ou não argumentos de entrada em sua assinatura }
  // declara o identificador PublicCommand como um procedimento sem argumentos:
 procedure PublicCommand;
 
  // declara um procedimento com um argumento:
 procedure AnotherPublicCommand(AString : string);
 
  // declara um procedimento com dois argumentos:
 procedure YetAnotherCommand(AString1 : string; AInteger : integer);
 
  { procedimentos declarados na interface devem ser redeclarados na implementação }
  implementation
  { procedimentos declarados apenas na implementação
     não podem ser vistos por outras unidades usando esta unidade }
 procedure PrivateCommand;
  begin
 end;
 
 procedure PublicCommand;
    procedure NestedCommand; 
    begin { procedimentos declarados dentro de procedimentos, chamados aninhados,
    end;  são visíveis apenas em seu bloco de execução }
  begin
    NestedCommand;  // executa o comando aninhado deste procedimento
    PrivateCommand; // executa um comando privado da unidade
 end;
 
 procedure AnotherPublicCommand(AString: string);
    procedure NestedCommand;
    begin
    end;
  begin
    NestedCommand;  // executa o comando aninhado deste procedimento
    PrivateCommand; // executa um comando privado da unidade
 end;
 
 procedure YetAnotherCommand(AString1: string; AString2: string);
 const                // constantes podem ser locais
    LConst = 10; 
 var                  // variáveis também podem ser locais
    LInteger : integer; 
    LBoolean : boolean;
    LString  : string;
    procedure LocalCommand; 
    begin
 
    end;
  begin
 end; 
 end.

 // declarando o procedimento AssignParameter
 procedure AssignParameter(AValue : integer):
 begin
    AValue := 20;
 end;
  {...}
  var
   i : integer = 10;
  begin
    AssignParameter(i); // chamando o procedimento AssignParameter
    // note que i permanece igual a 10
 end;

 // assinatura do procedimento Inc
 procedure Inc(var AVariable: TOrdinal);
  {...}
 var 
    InputVariable : integer = 0;      // inicializa i com o valor inicial 0
 begin // chamando o procedimento Inc
    Inc(InputVariable);               // incrementa i
    // InputVariable = 1  
 end;

 // assinatura do procedimento WriteStr
 procedure WriteStr(out OutputString: string; Args: Arguments);
  {...}
  var                                       // OutputString não possui um valor inicial, 
  OutputString : string;// pois não foi inicializada
  i : integer = 50;
  begin // chamando o procedimento WriteStr, ele converte i para texto 
    WriteStr(OutputString, i);// e inicializa Outputstring com '50'
    // OutputString = '50'
 end;

 // assinatura do procedimento ReadStr
 procedure ReadStr(const S: string; Args: Arguments);
  {...}
  // chamando o procedimento ReadStr
  var
    ConstantInput : string = '10 20 Texto';
    i1, i2 : integer;
    s : string;
  begin
  {
 
    Importante
    ****************
    Argumentos do tipo "Arguments" são especiais.
    Eles não podem ser redeclarados pelo programador, apenas usados por ele.
    O programador pode incluir diversos argumentos de tipos conhecidos
    na posição de um argumento "Arguments". 
    O compilador fará as conversões necessárias se elas forem possíveis.
    ****************
  }
    ReadStr(ConstantInput, i1, i2, s);
   
    // ConstantInput = '10 20 Texto'  
    // i1 = 10
    // i2 = 20
    // s = 'Texto'
 end;

 // declara uma função sem argumentos que retorna um boleano:
 function GetBoolean : Boolean;
 begin
    Result := true;
 end;
 
 // declara uma função que retorna um texto:
 function GetString : string;
 begin
    Result := 'texto';
 end;
 
 // declara uma função que retorna um valor inteiro:
 function GetInteger : integer;
 begin
   Result := 0;
 end;

uses SysUtils;   // unidade com muitas funções de conversão
 
{...}
 
 s := IntToStr(i); // converte um inteiro para texto 
 i := StrToInt(s); // converte um texto para inteiro
 i := StrToIntDef(s, 0); // converte um texto para inteiro, em caso de erro retorna 0
 b := StrToBoolDef(s, false) // converte um texto para boleano
                             // em caso de erro retorna false

  // declara o procedimento ManyStrings
 procedure ManyStrings(AStrings : array of string);
  var
    i : integer;
    s : string;
  begin
    for i := Low(AStrings) to High(AStrings) do
    begin
      s := AStrings[i];
    end;
 end;
 
  // chamando o procedimento ManyStrings
 
  begin
    ManyStrings(['texto1', 'texto2', 'texto3']);
    ManyStrings(['texto1', 'texto2']);
    ManyStrings(['texto1']);
 end;

var
  list : TStringList;
begin
  // criar uma lista de texto, isto é, reservar um espaço na memória para ela
  list := TStringList.Create;
 
  // limpar o conteúdo da lista
  list.Clear;
 
  // adicionar um texto ao final da lista
  list.Append('texto 1');
 
  // adicionar outro texto ao final da lista
  list.Append('texto 2');
 
  // alternar a posição de textos na lista 
  list.Exchange(0, 1);
 
  // liberar a lista da memória
  list.Free;
end; 

 type // inicia um bloco de declaração de tipo
    TNotifyEvent = procedure(Sender : TObject) of object;
 
  // O tipo de evento "TNotifyEvent" está declarado na unidade "Classes"
 
  // "Sender" é o objeto que enviou a mensagem
  // ou, em outras palavras, o objeto que disparou o evento

interface
   
type
  TMyForm = class(TForm)
    procedure SomeEvent(Sender : TObject);  
  private
    // internamente, eventos são uma variável
    FNotifyEvent : TNotifyEvent; 
   
    // e possuem um procedimento de escrita
    procedure SetNotifyEvent(ANotifyEvent : FNotifyEvent);
  public
   
    // eventos frequentemente são acessados por meio de propriedades
    property NotifyEvent : TNotifyEvent read FNotifyEvent write SetNotifyEvent;
  end;
   
  {
    Para atribuir um valor a um evento,
    use o prefixo "@" no procedimento alvo.
    Por exemplo, o procedimento "SomeEvent"
    poderia ser atribuído à "NotifyEvent" assim:
       
      NotifyEvent := @SomeEvent;
       
    e disparado assim:
       
      NotifyEvent(Self);
   
    "Self" é uma variável especial dentro de uma classe.
    Ela contém a identidade de um certo objeto.
    Todos os objetos possuem identidades diferentes. 
   
    Lembre que "evento" e "procedimento" devem
    possuir a mesma assinatura para que uma
    atribuição seja possível.
  }

  // diretivas incluídas por padrão nos módulos criados pelo Lazarus
 {$MODE ObjFPC}   // habilita a sintaxe de orientação ao objeto
 {$H+}            // Torna o tipo String um apelido para o tipo AnsiString
 
  // diretivas não incluídas por padrão nos arquivos,
  // mas passadas por padrão pelo Lazarus ao compilador
 {$COPERATORS ON} // habilita os operadores +=, -=, *= e /=
 {$GOTO ON}       // habilita as palavras-chave label e goto
 {$INLINE ON}     // habilita a declaração de procedimentos inline

 program ProjetoPiloto; // projetopiloto.lpr                 
 
  {$mode objfpc}{$H+} // diretivas de compilação 
 
 uses   // início do bloco de uso de unidades
    Interfaces, // uma interface específica para o sistema torna-se disponível 
    Forms,      // torna a classe TForm visível
    Unit1       // torna a variável Form1 visível  
 ;             // final do bloco de uso de unidades
 
  {$R *.res} // inclui recursos auxiliares no arquivo executável
 
 begin // início do bloco de execução central do programa
 
    // produz um erro se uma janela for criada sem recursos
    RequireDerivedFormResource:=true;  
     
    // inicializa a interface gráfica, dentre outras coisas...
    Application.Initialize;                
     
    // cria o componente TForm1 atribuindo o resultado à variável Form1
    Application.CreateForm(TForm1, Form1); 
     
    // carrega a janela principal (Form1) e o laço (loop) de eventos
    Application.Run;                       
 end. // final do bloco de execução central do programa 

 unit Forms.Main;    // título e início da unidade
 
 {$mode objfpc}{$H+} // diretivas de compilação
 
 interface           // bloco público da unidade
 
 uses          // bloco de uso com sete unidades
    Classes,    // classes e métodos para criação de objetos recorrentes 
    SysUtils,   // classes e métodos para conversões entre tipos básicos 
    FileUtil,   // classes e métodos para o manuseio de arquivos
    Forms,      // classes e métodos para a criação de janelas
    Controls,   // classes e métodos para a criação de controles visíveis
    Graphics,   // classes e métodos para o manuseio de imagens
    Dialogs;    // classes e métodos para a criação de caixas de mensagens
 
 type          // bloco de tipo
 
    // declara uma nova classe de janela (que você pode customizar)
    TForm1 = class(TForm) 
    private    // campo privado da classe
 
    public     // campo público da classe
 
    end;       // final da declaração da classe
 
 var          // bloco de declaração de variáveis
 
    // declara Form1 como um objeto da classe de janelas TForm1
    Form1: TForm1; 
 
 implementation // campo privado da unidade
 
  // inclui recursos auxiliares no arquivo executável da aplicação
  {$R *.lfm} 
 
 end. // final da unidade

 unit Timestamps;
 
  {$mode objfpc}{$H+}
 
  interface
 
  // essa função pode ser chamada muitas vezes
  // por isso a directiva "inline" é declarada ao final
 function Miliseconds(FirstTickCount : Cardinal) : string; inline; 
 
  implementation
 
 uses SysUtils; 
 
  // um registro cumulativo de tempo deve tomar 
  // o primeiro registro como referência (FirstTickCount)
 
  // o tipo cardinal só admite valores
  // inteiros maiores ou iguais a zero 
 function Miliseconds(FirstTickCount : Cardinal) : string;
  begin
    // a função GeTickCount64 retorna um tempo monotônico em milisegundos
    // a função IntToStr converte o valor para texto
    Result := IntToStr(GetTickCount64 - FirstTickCount);  
 end; 
 
 end.

 unit TabDelimitedReport;
 
  {$mode objfpc}{$H+}
 
  interface
 
  type
 
    { TTabDelimitedReport }
 
    TTabDelimitedReport = class
    private
      FFilename : string;
      FTextFile : TextFile;
      procedure SetFilename(AFilename: string);
    public
      procedure CloseFile;
      procedure NextFile;
      procedure WriteRow(Cols : array of string);
      property Filename : string read FFilename write SetFilename;
    end;
 
  var
    Report : TTabDelimitedReport;       // variável pública
 
  implementation
 
 uses SysUtils, LazFileUtils; // torna visível funções para o manuseio de arquivos
 
 procedure TTabDelimitedReport.WriteRow(Cols: array of string);
  const
    TAB = #9;
  var
    i : Integer;
    LastColumn : Integer;
  begin
    LastColumn := High(Cols);
    for i := 0 to LastColumn do          // percorre todos os itens
      if i < LastColumn then             // se antes do último item
        Write(FTextFile, Cols[i]+TAB)    // escreve item e TAB        
      else               // se último escreve item e final de linha
        WriteLn(FTextFile, Cols[i]);  
    Flush(FTextFile);                    // salva as mudanças no disco rígido 
 end;
 
 procedure TTabDelimitedReport.SetFilename(AFilename: string);
  var
    LFilePath, LExtension, LBasename: string;
    i : Integer;
  begin
                     // retorna o caminho raiz do nome de arquivo
    LFilePath := ExtractFilePath(AFilename);
 
                     // retorna apenas o nome base do arquivo
                     // sem extenção e sem caminho
    LBasename := ExtractFileNameOnly(AFilename);
 
                       // retorna a extenção do nome do arquivo
    LExtension := ExtractFileExt(AFilename);
 
                       // caso a extenção seja vazia ou .exe
                       // a extenção torna-se '.txt' 
    case LExtension of
    '', '.exe' : LExtension:='.txt';
    end;
 
                        // nunca subscreva um arquivo já existente
                        // se o arquivo existir, incremente seu nome
    i := 0;
    while FileExists(AFilename) do
      begin
        Inc(i);
        AFilename := LFilePath+LBasename+'_data_'+Format('%.3d', [i])+LExtension;
      end;
 
                         // atribui um nome ao arquivo de texto
    AssignFile(FTextFile, AFilename);
    Rewrite(FTextFile);    // abre o arquivo de texto para escrita
    FFilename:=AFilename;  // salva o nome do arquivo para uso posterior
 end;
 
 procedure TTabDelimitedReport.NextFile;
  begin
    SetFilename(FFilename);             // abre um novo arquivo
 end;
 
 procedure TTabDelimitedReport.CloseFile;
  begin
    System.Close(FTextFile);            // fecha o arquivo de texto
 end;
 
 initialization // antes de executar o programa, crie (a memória do) objeto
    Report := TTabDelimitedReport.Create;
 
 finalization   // após finalizar o programa, libere (a memória do) objeto
    Report.Free;
 
 end.

 implementation  // campo privado da unidade
 
  {$R *.lfm}
 
  // torna visível a variável do relatório (Report)
  // e a função Miliseconds
 uses TabDelimitedReport, Timestamps; 
 
 end.   

procedure TForm1.FormCreate(Sender: TObject);
begin
  // use a variável pública da unidade TabDelimitedReport
  // a propriedade Filename permite criar e inicializar
  // o arquivo de texto do relatório
  Report.Filename := Application.ExeName;

  // Application refere-se à variável
  // da unidade Forms. A propriedade ExeName
  // retorna o caminho completo do arquivo executável da aplicação
   
  // escreve o cabeçalho do programa
  Report.WriteRow(['Tempo', 'Categoria', 'Evento']);
end; 

 Tempo   Categoria         Evento
 0000   estimulo     S1
 2000   resposta     R1
 2500   estimulo     C1
 5050   estimulo     S1
 5500   resposta     R2
 6000   resposta     R2
 6100   resposta     R2
 7000   resposta     R2
 9000   resposta     R1
 9500   estimulo     C1

 unit Behavior.Events;
 
  {$mode objfpc}{$H+}
 
  interface
 
  uses
    Classes;   // torna visível a classe TObject
 
 type         // bloco de declaração de tipo
    // o procedimento recebe o nome de uma categoria, um evento
    // e o objeto que enviou a mensagem
    TBehavioralEvent = procedure(Sender: TObject; const Category: string;
   const Event:string) of object;
 
    // define as possíveis categorias como constantes simples
  const
    BehavioralEvent = 'resposta';
    EnviromentEvent = 'estimulo';
    SystemEvent = 'virtual';
 
  implementation
 
    // toda unidade precisa de um bloco de implementação
    // ainda que vazia
 
 end.

unit ExtCtrls.Stimulus;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  ExtCtrls,        // torna visível a unidade TImage
  Behavior.Events; // torna visível o evento TBehavioralEvent
 
type
  
  { TStimulus }
 
  TStimulus = class(TImage) // cria a classe TStimulus a partir da casse TImage
  private
    FOnVisibilityChange: TBehavioralEvent;
    procedure SetOnVisibilityChange(AValue: TBehavioralEvent);
  protected
    // a directiva override permite customizar o procedimento
    // SetVisible da classe Timage este procedimento é usado
    // para detectar a mudança de visibilidade dos estímulos
    procedure SetVisible(Value: Boolean); override;
  public
    // para declarar o evento comportamental
    // escreva "property OnVisibilityChange : TBehavioralEvent;"
    // e em seguida aperte CTRL+SHIFT+C
    // a propriedade será declarada automaticamente
  property OnVisibilityChange : TBehavioralEvent read FOnVisibilityChange write
 SetOnVisibilityChange;
  end;
 
implementation
 
{ TStimulus }
 
procedure TStimulus.SetOnVisibilityChange(AValue: TBehavioralEvent);
begin
  if FOnVisibilityChange=AValue then Exit;
  FOnVisibilityChange:=AValue;
end;
 
procedure TStimulus.SetVisible(Value: Boolean);
begin // implementação de eventos de estímulo 
  // primeiramente é necessário 
  // chamar o procedimento SetVisible de TImage
  // isso é possível por meio do prefixo inherited
  inherited SetVisible(Value);
  // se um valor foi atribuido à propriedade então
  if Assigned(OnVisibilityChange) then   
    if Value then // se visível
      // dispara o evento da propriedade como "Show"
      OnVisibilityChange(Self, EnviromentEvent, 'Show') 
    else          // se invisível
      // dispara o evento da propriedade como "Hide"
      OnVisibilityChange(Self, EnviromentEvent, 'Hide');
 end;
end.

  unit Forms.Main;
     
  {$mode objfpc}{$H+}
     
  interface
     
  uses
    Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
    ExtCtrls.Stimulus; // torna visível a classe TStimulus
     
  type
     
    { TForm1 }
     
    TForm1 = class(TForm)
      // declara um estímulo antecedente
      StimulusAntecedent : TStimulus;
     
      // declara um estímulo consequente 
      StimulusConsequent : TStimulus; 
     
      // declara o procedimento dos eventos de clique da janela
      procedure ComponentClick(Sender: TObject);  
     
      // declara o procedimento dos eventos de teclado da janela
      procedure ComponentKeyPress(Sender: TObject; var Key: char);
     
      // declara o procedimento de criação da janela
      procedure FormCreate(Sender: TObject);
      
      // declara o procedimento de destruição da janela
      procedure FormDestroy(Sender: TObject);
      
      // declara o procedimento de registro de respostas e estímulos
      procedure RecordBehavior(Sender: TObject; const Category:string;
        const EventSufix: string); inline;
    private
      // declara uma variável privada para o valor de início do registro
      FFirstTickcount : Cardinal;
     
      // declara um método de ajuda para a criação e configuração dos
      // estímulos
      procedure CreateStimulus(out AStimulus : TStimulus; AColor : TColor;
        ASize : integer = 300; ALeft : integer = 0; ATop: integer = 0);
    public
     
    end;
     
  var
    Form1: TForm1;
     
  implementation
     
  // unidades usadas apenas na implementação
  uses TabDelimitedReport, Timestamps, Behavior.Events; 
     
  {$R *.lfm}
     
  { TForm1 }
     
     
  // o que acontece quando a janela principal for criada?
 procedure TForm1.FormCreate(Sender: TObject);
  begin
  // cria o estímulo antecedente com cor preta
    CreateStimulus(StimulusAntecedent, clBlack,150,0,0);
     
    // cria o estímulo consequente com cor azul
    CreateStimulus(StimulusConsequent, clBlue,100,200,0);
     
    // os estímulos são rastreados pelos seus
    // respectivos nomes
    StimulusAntecedent.Name:='Preto';
    StimulusConsequent.Name:='Azul';
     
    // cabeçalho do relatório
    Report.Filename := Application.ExeName;
    Report.WriteRow(['Tempo', 'Categoria', 'Evento']);
     
    // valor de início do registro independente da hora local
    FFirstTickcount := GetTickCount64;
     
  // início de acordo com a data e hora local
    RecordBehavior(Sender, SystemEvent, 'inicio:'+DateTimeToStr(Now));
     
    // mostra o estímulo antecedente
    StimulusAntecedent.Show;
  end;
     
  // o que acontece quando a janela principal for destruida?
 procedure TForm1.FormDestroy(Sender: TObject);
  begin
    // registra o final de acordo com a hora local
    RecordBehavior(Sender, SystemEvent, 'final:'+DateTimeToStr(Now));
     
    // finaliza o relatório
    Report.CloseFile;
  end;
     
 procedure TForm1.RecordBehavior(Sender: TObject; const Category: string;
    const EventSufix: string);
  var
    SenderName: string;
  begin
    // o rastreamento ocorre por meio
    // do nome dos objetos
    if Sender is TComponent then
      SenderName := TComponent(Sender).Name
    else
      SenderName := Sender.ClassName;
     
  // registra uma linha no relatório
    Report.WriteRow([
      Miliseconds(FFirstTickcount),
      Category,
      SenderName+#32+EventSufix
    ]);
  end;
     
 procedure TForm1.CreateStimulus(out AStimulus: TStimulus; AColor: TColor;
    ASize: integer; ALeft: integer; ATop: integer);
  begin
    // note que AStimulus é um argumento de saída (out)
     
    // cria o estímulo na janela principal (self) 
    AStimulus := TStimulus.Create(Self);
     
    // define o tamanho do estímulo
    // Left e Top possuem origem no canto superior esquerdo do monitor:
    // Left pixel horizontal
    // Top pixel vertical
    AStimulus.SetBounds(ALeft, ATop, ASize, ASize);
     
    // define o tamanho da figura do estímulo
    AStimulus.Picture.Bitmap.SetSize(ASize, ASize);
     
    // define a cor da figura do estímulo
    AStimulus.Picture.Bitmap.Canvas.Brush.Color := AColor;
     
    // desenha um retângulo preenchido na figura com a cor definida
    AStimulus.Picture.Bitmap.Canvas.Rectangle(0,0, ASize, ASize);
     
  {****************** MUITO IMPORTANTE ********************}
     
    // não esqueça de definir aonde o estímulo será desenhado
    // isto é possível por meio da propriedade Parent
    // aqui definimos a janela principal (Self) como o
    // responsável por desenhar o estímulo
     
                                AStimulus.Parent := Self;
     
  {********************************************************}
     
    // define a visibilidade inicial do estímulo
    AStimulus.Hide;
     
    // atribui um valor às propriedades dos estímulos
    // o operador @ deve ser usado na frente do
    // procedimento correspondente ao evento
    // da propriedade
    // para relembrar a assinatura do evento
    // segure CTRL e clique com o botão esquerdo na
    // propriedade
    AStimulus.OnVisibilityChange:=@RecordBehavior;
    AStimulus.OnClick:=@ComponentClick;
  
    // também seria possível carregar uma figura 
    // por meio do nome do arquivo da figura
    // AStimulus.Picture.LoadFromFile(AFilename);
    // AStimulus.Stretch := True;
  end;
     
  // o que acontece quando um componente é clicado?
  procedure TForm1.ComponentClick(Sender: TObject);
  begin
    // registra o comportamento de clique
    RecordBehavior(Sender, BehavioralEvent, 'Click');
      
    // altera a visibilidade dos estímulos
    // de acordo com os estímulos clicados
    if Sender = StimulusAntecedent then
      begin
        StimulusAntecedent.Hide;
        StimulusConsequent.Show;
      end;
    if Sender = StimulusConsequent then
      begin
        StimulusConsequent.Hide;
        StimulusAntecedent.Show;
      end;
  end;
     
  // o que acontece quando uma tecla é pressionada
  // tendo um componente em foco?
  procedure TForm1.ComponentKeyPress(Sender: TObject; var Key: char);
  const
    SpaceKey = #32;
    DeleteKey = #127;
  var
    Event : string = '';
  begin
    case Key of
      SpaceKey : Event := '<32>';
      DeleteKey: Event := '<127>';
      #0..#31  : Event := '<NA>';
    end;
    RecordBehavior(Sender, BehavioralEvent, Event);
  end;
     
  end.