Ir para o conteúdo

Natal e Ano Novo 2016

{$mode objfpc}
{$unitpath lib}
program natal2016;
uses sysutils, strutils, types, math, ptccrt, ptcgraph,
     typex, graphix;

const
   // Códigos para as cores usadas
   GREEN  = 9900;
   YELLOW = 65200;
   BLUE   = 9500;
   ORANGE = 64200;

{$i inc/draw.inc}

const
   // Posicionamento da árvore; referência para restantes elementos
   INITPOS  : TPoint = (x:50; y:100);
   INITSIZE : TSize  = (cx:50; cy:100);
   ITERTREE = 5;
   // Textos a apresentar
   PROMPT1 = 'Merry Year';
   PROMPT2 = 'and a';
   PROMPT3 = 'Happy New Xmas!';
   PROMPT4 = '... or something...';
   // Velocidade da coloração da árvore
   SPEEDMIN  = 50;
   SPEEDMAX  = 1000;
   SPEEDSTEP = 50;
   // Gestão de cores da árvore
   COLORMIN  = 63487;
   COLORMAX  = 65535;
   COLORSTEP = 300;


var
   // Gestão gráfica
   err : smallint;            // Erro de inicialização
   driver, mode : smallint;   // Modo e driver a usar
   // Navegação e outros
   i, f  : longint;
   key   : char;
   speed : word = SPEEDMIN;

begin
   DetectGraph(driver, mode);
   mode := m1024x768;  // Override
   InitGraph(driver, mode, '');
   err := GraphResult;

   if err <> grOk then begin
       writeln('Initialization exception [InitGraph]: ', GraphErrorMsg(err));
       readln
   end else begin

      // Inicializa árvore
      SetFillStyle(SolidFill, 0);
      for i := 2 to ITERTREE do begin
         if i > 1 then
            Bar(INITPOS.x-5, INITPOS.y - 5, INITPOS.x * (i-1) + INITSIZE.cx * (i-1) + 5, INITPOS.y + INITSIZE.cy * (i-1) + 5);
         DrawTree(INITPOS, INITSIZE * i);
         Sleep(1000);
      end;

      // Coloca os textos
      SetTextStyle(SansSerifFont, HorizDir, GetBestFit(PROMPT4, (ITERTREE + 1) * INITSIZE.cx + 3 * INITPOS.x));
      SetColor(GREEN);
      SlideText((ITERTREE + 2) * INITSIZE.cx, 250, PROMPT1);
      SetColor(ORANGE);
      SlideText((ITERTREE + 2) * INITSIZE.cx, 300, PROMPT2);
      SetColor(YELLOW);
      SlideText((ITERTREE + 2) * INITSIZE.cx, 350, PROMPT3);
      Sleep(1500);
      SetColor(BLUE);
      SlideText((ITERTREE + 2) * INITSIZE.cx, 550, PROMPT4);

      // Legenda de utilização
      Sleep(500);
      SetTextStyle(SansSerifFont, HorizDir, 1);
      SetColor(GREEN);
      OutTextXY(INITPOS.x, 650, '  Velocidade = ' + IntToStr(speed) + ' ms  ');
      OutTextXY(INITPOS.x, 652, '_______________________');
      SetColor(BLUE);
      OutTextXY(INITPOS.x, 660, '+ aumentar | - diminuir');
      OutTextXY(INITPOS.x, 670, '0 minimo   | 1 maximo');
      SetColor(YELLOW);
      OutTextXY(INITPOS.x, 685, 'ESC  sair');

      // Animação da árvore
      SetColor(BLUE);
      i := YELLOW;
      f := 1;
      repeat
         while not KeyPressed do begin
            // Gestão automática de cores
            if i + COLORSTEP > COLORMAX then
               f := -1
            else if i - COLORSTEP < COLORMIN then
               f := 1;
            i := i + (COLORSTEP * f);

            DrawTree(INITPOS, INITSIZE * 5, i);
            Sleep(speed);
         end;

         // Tecla foi premida: qual?
         repeat
            key := ReadKey;
         until key <> #0;  // Descarta teclas "especiais"

         if key in ['+', '-', '0', '1'] then begin
            // Gestão da velocidade
            case key of
               '+' : if speed < SPEEDMAX then
                        Inc(speed, SPEEDSTEP);
               '-' : if speed > SPEEDMIN then
                        Dec(speed, SPEEDSTEP);
               '0' : speed := SPEEDMIN;
               '1' : speed := SPEEDMAX;
            end;

            // Actualiza indicador
            Bar(INITPOS.x, 650, INITPOS.x + TextWidth('_______________________'), 650 + TextHeight('X'));
            SetColor(GREEN);
            OutTextXY(INITPOS.x, 650, '  Velocidade = ' + IntToStr(speed) + ' ms  ');
         end;
      until key = #27;  // ESC para sair

      // Libertar recursos gráficos
      ClearDevice;
      CloseGraph;
   end;
end. 

type TPointList = array of TPoint;

function NewPoint(x, y : LongInt) : TPoint;
(* Cria TPoint in loco sem necessidade de variável temporária. *)
begin
   NewPoint.x := x;
   NewPoint.y := y;
end;

function NewSize(x, y : LongInt) : TSize;
(* Cria TSize in loco sem necessidade de variável temporária. *)
begin
   NewSize.cx := x;
   NewSize.cy := y;
end;


procedure DrawTree(position : TPoint; size : TSize; const COLORLINES : word = 65200);
(* Desenho da árvore, com gestão automática das ramificações. *)
const
   MINIMUM = 10;

var
   branches : longword = 0;      // Ramificações que constroem visualmente a árvore
   left  : TPointList = nil;     // Lado esquerdo da árvore
   right : TPointList = nil;     // Lado direito da árvore
   jump : longword;              // Para cálculo dos pontos
   i, x : longword;              // Auxiliares

begin
   // Ajuste automático de branches:
   i := 10;
   while (size.cx mod (2 * (size.cy div i)) <> 0) do Inc(i);
   branches := size.cy div i;
   if (branches < MINIMUM) then begin
      OutTextXY(10, 10, 'ERRO!');
      WriteLn('Ajuste automático falhou. As definicoes fornecidas sao lastimaveis!');
      Exit;
   end;

   // Árvore começa no canto inferior esquerdo e termina no vértice superior do triângulo
   // Vértice superior pode ficar em qualquer um dos lados da árvore: depende se 'branches' é par ou ímpar.
   // Sendo par, fica do lado esquerdo, logo ímpar é do lado direito.
   if (branches mod 2 = 0) then begin
      SetLength(left , branches div 2 + 1);
      SetLength(right, branches div 2);
   end else begin
      SetLength(left , (branches+1) div 2);
      SetLength(right, (branches+1) div 2);
   end;

   // Definição dos pontos dos dois lados:
   i := 0;
   x := 0;
   jump := size.cx div (2*branches);
   while i < Min(Length(left), Length(right)) do begin
      left[i].x  := x;
      left[i].y  := size.cy - (i*2)*(size.cy div branches);
      if i <= High(right) then begin
         right[i].x := size.cx - x - jump;
         right[i].y := size.cy - (i*2+1)*(size.cy div branches);
      end;
      Inc(x, 2*jump);
      Inc(i);
   end;

   SetColor(COLORLINES);
   SetLineStyle(SolidLn, 0, NormWidth);
   // Primeira linha
   Line(position.x + left[0].x,
        position.y + left[0].y,
        position.x + right[0].x,
        position.y + right[0].y);

   // Restantes linhas, excepto última
   for i := 1 to Min(Length(left), Length(right)) - 1 do begin
      Line(position.x + left[i].x,
           position.y + left[i].y,
           position.x + right[i].x,
           position.y + right[i].y);

      Line(position.x + right[i-1].x,
           position.y + right[i-1].y,
           position.x + left[i].x,
           position.y + left[i].y);
   end;

   // Última linha
   if (branches mod 2 = 0) then
      Line(position.x + right[i-1].x,
           position.y + right[i-1].y,
           position.x + left[i].x,
           position.y + left[i].y)
   else
      Line(position.x + left[High(left)].x,
           position.y + left[High(left)].y,
           position.x + right[High(right)].x,
           position.y + right[High(right)].y);

   // Triângulo
   SetColor(GREEN);
   SetLineStyle(SolidLn, 0, ThickWidth);
   Line(position.x, position.y + size.cy, position.x + size.cx, position.y + size.cy);
   Line(position.x, position.y + size.cy, position.x + size.cx div 2, position.y);
   Line(position.x + size.cx, position.y + size.cy, position.x + size.cx div 2, position.y);

   // Libertar recursos dos arrays dinâmicos
   SetLength(left, 0);
   SetLength(right, 0);
end;

(* Extension for unit types *)

{$mode objfpc}
unit typex;

interface
uses types;

// Facilita algumas contas...
operator * (s : TSize; v : LongInt) res : TSize;
operator * (v : LongInt; s : TSize) res : TSize;


implementation

operator * (s : TSize; v : LongInt) res : TSize;
begin
   res.cx := s.cx * v;
   res.cy := s.cy * v;
end;

operator * (v : LongInt; s : TSize) res : TSize;
begin
   res := s * v;
end;

end.

(* Extension for unit graph and ptcgraph *)

{$mode objfpc}
unit graphix;

interface
uses sysutils, ptcgraph;

function GetBestFit(const TXT : string; diff : word = 0) : Word;
procedure SlideText(const X, Y : word; const PROMPT : string);


implementation

function GetBestFit(const TXT : string; diff : word = 0) : Word;
(* Obtém o melhor tamanho de letra para a dimensão horizontal da janela.
   diff -> Factor de redução de GetMaxX                                  *)

var i : word = 0;
begin
   while TextWidth(TXT) < (GetMaxX - diff) do begin
      Inc(i);
      SetTextStyle(SansSerifFont, HorizDir, i);
   end;
   GetBestFit := i;
end;


procedure SlideText(const X, Y : word; const PROMPT : string);
(* Animação de texto: aparece letra a letra a cada décimo de segundo. *)
var i : word;
begin
   for i := 1 to Length(PROMPT) do begin
      OutTextXY(X + TextWidth('X') * (i-1), Y, PROMPT[i]);
      if PROMPT[i] <> ' ' then
         Sleep(100);
   end;
end;

end.